Routine: PSOB

PSOB ;BHAM ISC/CCG - black line resolver ; 07/18/96  8:49 am

 ;;7.0;OUTPATIENT PHARMACY;**10,60,193,367**;DEC 1997;Build 62

 I '$D(PSOPAR) D ^PSOLSET Q:'$G(PSOPAR)

 S (CC,PSOCLC,PDUZ)=DUZ,PSOBOUT=0

 N PSODISP,PSOMGREP

 I '$O(^PS(52.9,0)) W !!,"THE LABEL/PROFILE MONITOR LIST IS EMPTY.",!! Q

 K DIR,DIRUT

 I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D  I $D(DIRUT) Q

 .S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"

 .D ^DIR K DIR I $D(DIRUT) Q

 .S PSODISP=Y

 K DIR,DIRUT

 I $$GET1^DIQ(59,PSOSITE,134)'="" D  I $D(DIRUT) Q

 . W ! S DIR("A")="Reprint the FDA Medication Guide",DIR(0)="Y",DIR("B")="No"

 . D ^DIR K DIR Q:$D(DIRUT)  S PSOMGREP=Y

PT W ! S DIC="^PS(52.9,",DIC("A")="ENTER FAILED OUTPUT DEVICE NUMBER OR NAME: ",DIC(0)="QEAZM" D ^DIC K DIC G END:Y=-1 S PSOBIO=+Y,PSOBPT=Y(0)

RX1 S DIC("A")="ENTER LAST USABLE LABEL/PROFILE : ",DIC="^PS(52.9,PSOBIO,1,",DIC(0)="EQAMZ" D ^DIC G:"^"[X END G:Y=-1 RX1 S PSOBY=Y,PSODPT=Y(0,0),PSODPT(0)=Y(0) K DIC

 I 'X S DA(1)=+Y,DIC("A")="ENTER LAST USABLE Rx: ",DIC="^PS(52.9,PSOBIO,1,DA(1),2,",DIC(0)="EQAMZ" D ^DIC G:"^"[X END G:Y=-1 RX1 D  G:$G(PSOBOUT) END

 .S PSOBR=+PSOBPT,Y(0)=PSODPT(0),Y(0,0)=PSODPT,Y=+PSOBY_"^"_$P(Y,"^",2) D RX08 S PSOBR1=PSOBR K DIC

 S PSOBR=+Y D RX08 G:$G(PSOBOUT) END S PSOBR1=PSOBR

RX2 S DIC="^PS(52.9,PSOBIO,1,",DIC(0)="EQAMZ",DIC("A")="ENTER NEXT USABLE LABEL/PROFILE ('RETURN' FOR REMAINDER OF THE QUEUE):",DIC("S")="I +PSOBR1'>Y" D ^DIC K DIC("S") G:X="^" END

 I X="" S PSOBR2=$P(^PS(52.9,PSOBIO,1,0),"^",3) S:$D(^PS(52.9,PSOBIO,1,PSOBR2,2)) PSOBR2=PSOBR2_"^"_($P(^PS(52.9,PSOBIO,1,PSOBR2,2,0),"^",3)+1) G SET

 G:Y=-1 RX2 S PSOBR=$P(Y,"^") D RX08 S PSOBR2=PSOBR I +PSOBR1=+PSOBR2,$P(PSOBR1,"^",2)>$P(PSOBR2,"^",2) W !!,"THE ENDING RX# DOES NOT FOLLOW THE BEGINNING RX#.  PLEASE TRY AGAIN.",!!! G RX1

SET N PSOBAR1,PSOBAR0,PSOBARS,IOS

 K ZTSK,%ZIS S DIC="^%ZIS(1,",(PSOIOS,DA)=PSOBPT,DR=".01;3",DIQ="DPTR",DIQ(0)="I" D EN^DIQ1

 S DPTRS=$G(DPTR(3.5,DA,3,DIQ(0))),PSOIS=PSOIOS,%ZIS("A")="PRINT ON DEVICE:  ",%ZIS("B")=$S($G(DPTR(3.5,DA,.01,DIQ(0)))'="":$G(DPTR(3.5,DA,.01,DIQ(0))),1:""),%ZIS="QMN" D ^%ZIS

 K %ZIS G:POP END

 I $E(IOST,1,2)="C-" W $C(7),!,"Output MUST be sent to a printer !!",! G SET

 S ZTIO=ION,PSOIOS=IOS,DA=IOST(0)

 S DIC="^%ZIS(2,",DR="61;60",DIQ="DPTRS1",DIQ(0)="I" D EN^DIQ1

 S PSOBAR0="" I $G(DPTRS1(3.2,DA,61,DIQ(0)))'="" S PSOBAR0=$G(DPTRS1(3.2,DA,61,DIQ(0)))

 S PSOBAR1="" I $G(DPTRS1(3.2,DA,60,DIQ(0)))'="" S PSOBAR1=$G(DPTRS1(3.2,DA,60,DIQ(0)))

 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19) S PSOBFLAG=1 D LASK^PSOLSET K PSOBFLAG

 ; Asking FDA Med Guide printer

 I $G(PSOMGREP),$$GET1^DIQ(59,PSOSITE,134)'="" N FDAPRT S FDAPRT="" D  I FDAPRT="^"!($G(PSOFDAPT)="") G END

 . F  D  Q:FDAPRT'=""

 . . S FDAPRT=$$SELPRT^PSOFDAUT($P($G(PSOFDAPT),"^"))

 . . I FDAPRT="" W $C(7),!,"You must select a valid FDA Medication Guide printer."

 . I FDAPRT'="",(FDAPRT'="^") S PSOFDAPT=FDAPRT

 S ZTRTN="PSOBMST",ZTDTH=$H,ZTDESC="BLACK LINE RESOLVER",(ZTSAVE("PSOBR1"),ZTSAVE("PSOBR2"),ZTSAVE("PSOBIO"),ZTSAVE("CC"),ZTSAVE("PDUZ"),ZTSAVE("PSOPAR"),ZTSAVE("PSOSITE"),ZTSAVE("PSODIV"))=""

 S (ZTSAVE("PSOIOS"),ZTSAVE("PSOBAR0"),ZTSAVE("PSOBAR1"),ZTSAVE("PSOBARS"),ZTSAVE("PSOSYS"))="",ZTSAVE("PSODISP")="",ZTSAVE("PSOMGREP")="",ZTSAVE("PSOFDAPT")=""

 D ^%ZTLOAD I $G(ZTSK) W !,"Task Queued #"_ZTSK_" !!",!

END D ^%ZISC K PSOIS,ZTSK,%ZIS,CC,DIC,IOP,I,POP,PSOB,PSOBIO,PSOBPT,PSOBR,PSOBR1,PSOBR2,PSOBRX,PSODPT,X,Y,PSOBOUT,DPTR,DPTRS,DPTRS1,DIQ,DIQ(0),DA,DR Q

RX08 I $P(Y(0),"^",2)="L" S:(X'=$P(Y,"^",2))&($O(^PSRX("B",X,0))) Y=+Y_"^"_$O(^PSRX("B",X,0)) S PSOBR=PSOBR_"^"_$O(^PS(52.9,PSOBIO,1,"C",$P(Y,"^",2),PSOBR,0)),PSOBRX=$P(Y,"^",2)

 E  S PSOBR=PSOBR_"^",PSOBRX="" S:$D(^PS(52.9,PSOBIO,1,PSOBR,2,0)) PSOBR=PSOBR_$P(^(0),"^",3),PSOBRX=^($P(PSOBR2,"^",2),0)

 Q:($P(PSOBR,"^",2))!('$D(^PS(52.9,PSOBIO,1,+PSOBR,2,0)))

 S PSOB="^" F I=0:0 S I=$O(^PS(52.9,PSOBIO,1,+PSOBR,2,I)) Q:'I  S PSOB=PSOB_$P(^PSRX($P(^(I,0),"^"),0),"^")_"^"

 I $P(PSOB,"^",3)="" S PSOBR=+PSOBR_"^"_$P(^PS(52.9,PSOBIO,1,+PSOBR,2,0),"^",3) Q

 I $P(Y(0),"^",2)="P" S PSOBR=+PSOBR_"^" Q

RX05 W !,"ENTER RX# OF LAST USABLE SCRIPT FOR "_$P(^DPT(+Y(0),0),"^")_": " R X:DTIME I '$T!(X["^") S PSOBOUT=1 Q

 D:X="?" LIST G:"^"[X RX05 I PSOB'[(U_X_"^") W !!,"???" G RX05

 S PSOBR=+PSOBR_"^"_($O(^PS(52.9,PSOBIO,1,"C",$O(^PSRX("B",X,0)),+PSOBR,0))) Q

LIST W !! F I=2:1 Q:$P(PSOB,"^",I)=""  W !,?5,I-1,"              ",$P(PSOB,"^",I)

RL W !,"CHOOSE 1-",I-2," : " R X:DTIME G:(X<1)!(X>(I-2)) RL S X=$P(PSOB,"^",X+1) Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOB   4588     printed  Mar 13, 2025@21:29:31                                                                                                                                                                                                        Page 2

PSOB      ;BHAM ISC/CCG - black line resolver ; 07/18/96  8:49 am

 +1       ;;7.0;OUTPATIENT PHARMACY;**10,60,193,367**;DEC 1997;Build 62

 +2        IF '$DATA(PSOPAR)

               DO ^PSOLSET

               if '$GET(PSOPAR)

                   QUIT

 +3        SET (CC,PSOCLC,PDUZ)=DUZ

           SET PSOBOUT=0

 +4        NEW PSODISP,PSOMGREP

 +5        IF '$ORDER(^PS(52.9,0))

               WRITE !!,"THE LABEL/PROFILE MONITOR LIST IS EMPTY.",!!

               QUIT

 +6        KILL DIR,DIRUT

 +7        IF $PIECE(PSOPAR,"^",30)

               IF $$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4

                   Begin DoDot:1

 +8                    SET DIR("A")="Do you want to resend to Dispensing System Device"

                       SET DIR(0)="Y"

                       SET DIR("B")="No"

 +9                    DO ^DIR

                       KILL DIR

                       IF $DATA(DIRUT)

                           QUIT

 +10                   SET PSODISP=Y

                   End DoDot:1

                   IF $DATA(DIRUT)

                       QUIT

 +11      ;

 +12       KILL DIR,DIRUT

 +13       IF $$GET1^DIQ(59,PSOSITE,134)'=""

               Begin DoDot:1

 +14               WRITE !

                   SET DIR("A")="Reprint the FDA Medication Guide"

                   SET DIR(0)="Y"

                   SET DIR("B")="No"

 +15               DO ^DIR

                   KILL DIR

                   if $DATA(DIRUT)

                       QUIT

                   SET PSOMGREP=Y

               End DoDot:1

               IF $DATA(DIRUT)

                   QUIT

 +16      ;

PT         WRITE !

           SET DIC="^PS(52.9,"

           SET DIC("A")="ENTER FAILED OUTPUT DEVICE NUMBER OR NAME: "

           SET DIC(0)="QEAZM"

           DO ^DIC

           KILL DIC

           if Y=-1

               GOTO END

           SET PSOBIO=+Y

           SET PSOBPT=Y(0)

RX1        SET DIC("A")="ENTER LAST USABLE LABEL/PROFILE : "

           SET DIC="^PS(52.9,PSOBIO,1,"

           SET DIC(0)="EQAMZ"

           DO ^DIC

           if "^"[X

               GOTO END

           if Y=-1

               GOTO RX1

           SET PSOBY=Y

           SET PSODPT=Y(0,0)

           SET PSODPT(0)=Y(0)

           KILL DIC

 +1        IF 'X

               SET DA(1)=+Y

               SET DIC("A")="ENTER LAST USABLE Rx: "

               SET DIC="^PS(52.9,PSOBIO,1,DA(1),2,"

               SET DIC(0)="EQAMZ"

               DO ^DIC

               if "^"[X

                   GOTO END

               if Y=-1

                   GOTO RX1

               Begin DoDot:1

 +2                SET PSOBR=+PSOBPT

                   SET Y(0)=PSODPT(0)

                   SET Y(0,0)=PSODPT

                   SET Y=+PSOBY_"^"_$PIECE(Y,"^",2)

                   DO RX08

                   SET PSOBR1=PSOBR

                   KILL DIC

               End DoDot:1

               if $GET(PSOBOUT)

                   GOTO END

 +3        SET PSOBR=+Y

           DO RX08

           if $GET(PSOBOUT)

               GOTO END

           SET PSOBR1=PSOBR

RX2        SET DIC="^PS(52.9,PSOBIO,1,"

           SET DIC(0)="EQAMZ"

           SET DIC("A")="ENTER NEXT USABLE LABEL/PROFILE ('RETURN' FOR REMAINDER OF THE QUEUE):"

           SET DIC("S")="I +PSOBR1'>Y"

           DO ^DIC

           KILL DIC("S")

           if X="^"

               GOTO END

 +1        IF X=""

               SET PSOBR2=$PIECE(^PS(52.9,PSOBIO,1,0),"^",3)

               if $DATA(^PS(52.9,PSOBIO,1,PSOBR2,2))

                   SET PSOBR2=PSOBR2_"^"_($PIECE(^PS(52.9,PSOBIO,1,PSOBR2,2,0),"^",3)+1)

               GOTO SET

 +2        if Y=-1

               GOTO RX2

           SET PSOBR=$PIECE(Y,"^")

           DO RX08

           SET PSOBR2=PSOBR

           IF +PSOBR1=+PSOBR2

               IF $PIECE(PSOBR1,"^",2)>$PIECE(PSOBR2,"^",2)

                   WRITE !!,"THE ENDING RX# DOES NOT FOLLOW THE BEGINNING RX#.  PLEASE TRY AGAIN.",!!!

                   GOTO RX1

SET        NEW PSOBAR1,PSOBAR0,PSOBARS,IOS

 +1        KILL ZTSK,%ZIS

           SET DIC="^%ZIS(1,"

           SET (PSOIOS,DA)=PSOBPT

           SET DR=".01;3"

           SET DIQ="DPTR"

           SET DIQ(0)="I"

           DO EN^DIQ1

 +2        SET DPTRS=$GET(DPTR(3.5,DA,3,DIQ(0)))

           SET PSOIS=PSOIOS

           SET %ZIS("A")="PRINT ON DEVICE:  "

           SET %ZIS("B")=$SELECT($GET(DPTR(3.5,DA,.01,DIQ(0)))'="":$GET(DPTR(3.5,DA,.01,DIQ(0))),1:"")

           SET %ZIS="QMN"

           DO ^%ZIS

 +3        KILL %ZIS

           if POP

               GOTO END

 +4        IF $EXTRACT(IOST,1,2)="C-"

               WRITE $CHAR(7),!,"Output MUST be sent to a printer !!",!

               GOTO SET

 +5        SET ZTIO=ION

           SET PSOIOS=IOS

           SET DA=IOST(0)

 +6        SET DIC="^%ZIS(2,"

           SET DR="61;60"

           SET DIQ="DPTRS1"

           SET DIQ(0)="I"

           DO EN^DIQ1

 +7        SET PSOBAR0=""

           IF $GET(DPTRS1(3.2,DA,61,DIQ(0)))'=""

               SET PSOBAR0=$GET(DPTRS1(3.2,DA,61,DIQ(0)))

 +8        SET PSOBAR1=""

           IF $GET(DPTRS1(3.2,DA,60,DIQ(0)))'=""

               SET PSOBAR1=$GET(DPTRS1(3.2,DA,60,DIQ(0)))

 +9        SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",19)

           SET PSOBFLAG=1

           DO LASK^PSOLSET

           KILL PSOBFLAG

 +10      ;

 +11      ; Asking FDA Med Guide printer

 +12       IF $GET(PSOMGREP)

               IF $$GET1^DIQ(59,PSOSITE,134)'=""

                   NEW FDAPRT

                   SET FDAPRT=""

                   Begin DoDot:1

 +13                   FOR

                           Begin DoDot:2

 +14                           SET FDAPRT=$$SELPRT^PSOFDAUT($PIECE($GET(PSOFDAPT),"^"))

 +15                           IF FDAPRT=""

                                   WRITE $CHAR(7),!,"You must select a valid FDA Medication Guide printer."

                           End DoDot:2

                           if FDAPRT'=""

                               QUIT

 +16                   IF FDAPRT'=""

                           IF (FDAPRT'="^")

                               SET PSOFDAPT=FDAPRT

                   End DoDot:1

                   IF FDAPRT="^"!($GET(PSOFDAPT)="")

                       GOTO END

 +17      ;

 +18       SET ZTRTN="PSOBMST"

           SET ZTDTH=$HOROLOG

           SET ZTDESC="BLACK LINE RESOLVER"

           SET (ZTSAVE("PSOBR1"),ZTSAVE("PSOBR2"),ZTSAVE("PSOBIO"),ZTSAVE("CC"),ZTSAVE("PDUZ"),ZTSAVE("PSOPAR"),ZTSAVE("PSOSITE"),ZTSAVE("PSODIV"))=""

 +19       SET (ZTSAVE("PSOIOS"),ZTSAVE("PSOBAR0"),ZTSAVE("PSOBAR1"),ZTSAVE("PSOBARS"),ZTSAVE("PSOSYS"))=""

           SET ZTSAVE("PSODISP")=""

           SET ZTSAVE("PSOMGREP")=""

           SET ZTSAVE("PSOFDAPT")=""

 +20       DO ^%ZTLOAD

           IF $GET(ZTSK)

               WRITE !,"Task Queued #"_ZTSK_" !!",!

END        DO ^%ZISC

           KILL PSOIS,ZTSK,%ZIS,CC,DIC,IOP,I,POP,PSOB,PSOBIO,PSOBPT,PSOBR,PSOBR1,PSOBR2,PSOBRX,PSODPT,X,Y,PSOBOUT,DPTR,DPTRS,DPTRS1,DIQ,DIQ(0),DA,DR

           QUIT

RX08       IF $PIECE(Y(0),"^",2)="L"

               if (X'=$PIECE(Y,"^",2))&($ORDER(^PSRX("B",X,0)))

                   SET Y=+Y_"^"_$ORDER(^PSRX("B",X,0))

               SET PSOBR=PSOBR_"^"_$ORDER(^PS(52.9,PSOBIO,1,"C",$PIECE(Y,"^",2),PSOBR,0))

               SET PSOBRX=$PIECE(Y,"^",2)

 +1       IF '$TEST

               SET PSOBR=PSOBR_"^"

               SET PSOBRX=""

               if $DATA(^PS(52.9,PSOBIO,1,PSOBR,2,0))

                   SET PSOBR=PSOBR_$PIECE(^(0),"^",3)

                   SET PSOBRX=^($PIECE(PSOBR2,"^",2),0)

 +2        if ($PIECE(PSOBR,"^",2))!('$DATA(^PS(52.9,PSOBIO,1,+PSOBR,2,0)))

               QUIT

 +3        SET PSOB="^"

           FOR I=0:0

               SET I=$ORDER(^PS(52.9,PSOBIO,1,+PSOBR,2,I))

               if 'I

                   QUIT

               SET PSOB=PSOB_$PIECE(^PSRX($PIECE(^(I,0),"^"),0),"^")_"^"

 +4        IF $PIECE(PSOB,"^",3)=""

               SET PSOBR=+PSOBR_"^"_$PIECE(^PS(52.9,PSOBIO,1,+PSOBR,2,0),"^",3)

               QUIT

 +5        IF $PIECE(Y(0),"^",2)="P"

               SET PSOBR=+PSOBR_"^"

               QUIT

RX05       WRITE !,"ENTER RX# OF LAST USABLE SCRIPT FOR "_$PIECE(^DPT(+Y(0),0),"^")_": "

           READ X:DTIME

           IF '$TEST!(X["^")

               SET PSOBOUT=1

               QUIT

 +1        if X="?"

               DO LIST

           if "^"[X

               GOTO RX05

           IF PSOB'[(U_X_"^")

               WRITE !!,"???"

               GOTO RX05

 +2        SET PSOBR=+PSOBR_"^"_($ORDER(^PS(52.9,PSOBIO,1,"C",$ORDER(^PSRX("B",X,0)),+PSOBR,0)))

           QUIT

LIST       WRITE !!

           FOR I=2:1

               if $PIECE(PSOB,"^",I)=""

                   QUIT

               WRITE !,?5,I-1,"              ",$PIECE(PSOB,"^",I)

RL         WRITE !,"CHOOSE 1-",I-2," : "

           READ X:DTIME

           if (X<1)!(X>(I-2))

               GOTO RL

           SET X=$PIECE(PSOB,"^",X+1)

           QUIT

PSOB.m