PRSAUTL.m

PRSAUTL ; HISC/REL-Utilities ;6/4/93  11:19

 ;;4.0;PAID;**21**;Sep 21, 1995

 S USR="",SSN=$P($G(^VA(200,DUZ,1)),"^",9)

 I SSN="" W !!,*7,"Your SSN was not found in the New Person File!" S TLI="" Q

 S USR=$O(^PRSPC("SSN",SSN,0))

TL ; Select T&L from among those allowed

 K DIC I PRSTLV>5 G P1

 S Z1=$S(PRSTLV=2:"T",PRSTLV="3":"S",1:"*")

 S TLI=$O(^PRST(455.5,"A"_Z1,DUZ,0)) I TLI<1 W !!,*7,"No T&L Units have been assigned to you!" Q

 I $O(^PRST(455.5,"A"_Z1,DUZ,TLI))<1 G P2

 S DIC("S")="I $D(^PRST(455.5,+Y,Z1,DUZ))"

P1 S DIC="^PRST(455.5,",DIC(0)="AEQM",DIC("A")="Select T&L Unit: " W ! D ^DIC K DIC I "^"[X!$D(DTOUT) S TLI="" Q

 G:Y<1 P1 S TLI=+Y

P2 S TLE=$P($G(^PRST(455.5,TLI,0)),"^",1) Q

QUE ; Queue a task

 K IO("Q"),ZTUCI,ZTDTH,ZTIO,ZTSAVE S ZTRTN=PRSAPGM,ZTREQ="@"

 S ZTSAVE("ZTREQ")="",ZTSAVE("PRSTLV")="",ZTDESC=$P(XQY0,"^",1)

 F V3=1:1 S V1=$P(PRSALST,"^",V3) Q:V1=""  S ZTSAVE(V1)=""

 D ^%ZTLOAD D ^%ZISC U IO W !,"Request Queued",! K V1,V3,PRSAPGM,PRSALST,ZTSK Q

CONTINUE() ;ASK USER TO CONTINE

 ;

 S ANSWER=1

 S DIR("A")="Continue"

 S DIR(0)="Y",DIR("B")="NO" D ^DIR

 I $D(DIRUT)!(Y=0) S ANSWER=0

 Q ANSWER

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRSAUTL   1148     printed  Sep 02, 2024@19:10:15                                                                                                                                                                                                     Page 2

PRSAUTL   ; HISC/REL-Utilities ;6/4/93  11:19

 +1       ;;4.0;PAID;**21**;Sep 21, 1995

 +2        SET USR=""

           SET SSN=$PIECE($GET(^VA(200,DUZ,1)),"^",9)

 +3        IF SSN=""

               WRITE !!,*7,"Your SSN was not found in the New Person File!"

               SET TLI=""

               QUIT 

 +4        SET USR=$ORDER(^PRSPC("SSN",SSN,0))

TL        ; Select T&L from among those allowed

 +1        KILL DIC

           IF PRSTLV>5

               GOTO P1

 +2        SET Z1=$SELECT(PRSTLV=2:"T",PRSTLV="3":"S",1:"*")

 +3        SET TLI=$ORDER(^PRST(455.5,"A"_Z1,DUZ,0))

           IF TLI<1

               WRITE !!,*7,"No T&L Units have been assigned to you!"

               QUIT 

 +4        IF $ORDER(^PRST(455.5,"A"_Z1,DUZ,TLI))<1

               GOTO P2

 +5        SET DIC("S")="I $D(^PRST(455.5,+Y,Z1,DUZ))"

P1         SET DIC="^PRST(455.5,"

           SET DIC(0)="AEQM"

           SET DIC("A")="Select T&L Unit: "

           WRITE !

           DO ^DIC

           KILL DIC

           IF "^"[X!$DATA(DTOUT)

               SET TLI=""

               QUIT 

 +1        if Y<1

               GOTO P1

           SET TLI=+Y

P2         SET TLE=$PIECE($GET(^PRST(455.5,TLI,0)),"^",1)

           QUIT 

QUE       ; Queue a task

 +1        KILL IO("Q"),ZTUCI,ZTDTH,ZTIO,ZTSAVE

           SET ZTRTN=PRSAPGM

           SET ZTREQ="@"

 +2        SET ZTSAVE("ZTREQ")=""

           SET ZTSAVE("PRSTLV")=""

           SET ZTDESC=$PIECE(XQY0,"^",1)

 +3        FOR V3=1:1

               SET V1=$PIECE(PRSALST,"^",V3)

               if V1=""

                   QUIT 

               SET ZTSAVE(V1)=""

 +4        DO ^%ZTLOAD

           DO ^%ZISC

           USE IO

           WRITE !,"Request Queued",!

           KILL V1,V3,PRSAPGM,PRSALST,ZTSK

           QUIT 

CONTINUE() ;ASK USER TO CONTINE

 +1       ;

 +2        SET ANSWER=1

 +3        SET DIR("A")="Continue"

 +4        SET DIR(0)="Y"

           SET DIR("B")="NO"

           DO ^DIR

 +5        IF $DATA(DIRUT)!(Y=0)

               SET ANSWER=0

 +6        QUIT ANSWER