DCL SPCPTR .P1 PARM;
DCL DD PARM-USER     CHAR(10) BAS(.P1);

DCL SPCPTR .P2 PARM;
DCL DD PARM-PASSWORD CHAR(10) BAS(.P2);

DCL SPCPTR .P3 PARM;
DCL DD PARM-RESULT   CHAR(1)  BAS(.P3); /* Y = OK, N = NOT OK */

DCL OL PARMS(.P1, .P2, .P3) EXT PARM MIN(3);

DCL SPCPTR .RECEIVER INIT(RECEIVER);
DCL DD      RECEIVER CHAR(2000);
    DCL DD  RCV-BYTES-RETURNED  BIN(4) DEF(RECEIVER) POS( 1);
    DCL DD  RCV-BYTES-AVAILABLE BIN(4) DEF(RECEIVER) POS( 5);
    DCL DD  RCV-USER-PROFILE  CHAR(10) DEF(RECEIVER) POS( 9);
    DCL DD  RCV-DATA        CHAR(1982) DEF(RECEIVER) POS(19);
        DCL DD RCV-ENCRYPTED-PASSWORD CHAR(16) DEF(RCV-DATA) POS(2);

DCL SPCPTR .LENGTH INIT(LENGTH);
DCL DD      LENGTH BIN(4)  INIT(2000);

DCL SPCPTR .FORMAT INIT(FORMAT);
DCL DD      FORMAT CHAR(8) INIT("UPWD0100");

DCL SPCPTR .USER   INIT(USER);
DCL DD      USER   CHAR(10);

DCL SPCPTR .ERROR  INIT(ERROR);
DCL DD      ERROR  BIN(4)  INIT(0);

DCL OL QSYRUPWD (.RECEIVER, .LENGTH, .FORMAT, .USER, .ERROR);

DCL SYSPTR .SEPT(6440) BAS(SEPT-POINTER);
DCL SPC PROCESS-COMMUNICATION-OBJECT BASPCO;
    DCL SPCPTR SEPT-POINTER DIR;

DCL DD EPWD CHAR(16); /* ENCRYPTED PASSWORD             */
DCL DD PWD  CHAR(24); /* GIVEN PASSWORD TO 24 POSITIONS */
DCL DD WORK CHAR(1);
DCL DD SHIFT BIN(2) UNSGND;
DCL DD N     BIN(2);
DCL DD P     BIN(2);

DCL DD CONTROL CHAR(32);
    DCL DD CTRL-FUNCTION CHAR(2) DEF(CONTROL) POS(1) INIT(X'0002');
    DCL DD CTRL-SIZE      BIN(2) DEF(CONTROL) POS(3) INIT(8);
    DCL DD CTRL-OPTION   CHAR(1) DEF(CONTROL) POS(5) INIT(X'00');
    DCL DD KEY           CHAR(8) DEF(CONTROL) POS(6);

DCL SPCPTR .CRYPT INIT(CRYPT);
DCL DD      CRYPT CHAR(8);

/*******************************************************************/

ENTRY * (PARMS) EXT;
    CPYBLA       PARM-RESULT, "N"; /* ASSUME BAD */
    CPYBLAP      PWD , PARM-PASSWORD, " ";
    CPYBLA       USER, PARM-USER;
    CALLX       .SEPT(5723), QSYRUPWD, *;

    CPYBREP      EPWD, " ";     /* CLEAR ENCRYPTED PASSWORD */
    CMPBLA(B)    USER(9:2), "  "/EQ(PREPARE-TO-ENCRYPT);
    CPYNV        N, 8;          /* START FROM THE END */
FOLD:
    SUBN         SHIFT, N ,1;
    ADDN(S)      SHIFT, SHIFT;
    CPYBTLLS     WORK, USER(9:2), SHIFT;
    AND(S)       WORK, X'C0'; /* TOP TWO BITS */
    XOR(S)       USER(N:1), WORK;
    SUBN(SB)     N, 1/POS(FOLD);

PREPARE-TO-ENCRYPT:
    CPYNV        P, 1;
ENCRYPT:
    CPYBLAP      KEY, PWD(P:8), X'40';        /* STEP 1 */
    BRK "1";
    CMPBLA(B)    KEY, X'40'/EQ(CHECK);

    XOR(S)       KEY, X'5555555555555555';    /* STEP 2 */
    ADDLC(S)     KEY, KEY;                    /* STEP 3 */
    CIPHER      .CRYPT, CONTROL, .USER;
    CPYBLA       EPWD(P:8), CRYPT;
    ADDN(SB)     P, 8/POS(ENCRYPT);

CHECK:
    CMPBLA(B)    EPWD, RCV-ENCRYPTED-PASSWORD/NEQ(=+2);
    CPYBLA       PARM-RESULT, "Y";:
    BRK "1";
    RTX          *;