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 Sep 23, 2025@20:00:53 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
