APSPSOB ;BHAM/ISC/CCG - BLACK LINE RESOLVER [ 09/09/97 8:45 AM ]
;;6.0;OUTPATIENT PHARMACY;;09/03/97
;;6.0;OUTPATIENT PHARMACY;**31,78,101,143**;09/03/97
S APSPKEYZ=1 ;IHS/DSD/ENM 07/01/97
I '$D(PSOPAR) D ^PSOLSET Q:'$G(PSOPAR)
I '$D(PSOIOS) S PSOIOS=IOS ;IHS/DSD/ENM 06/10/97
S (CC,PSOCLC,PDUZ)=DUZ,PSOBOUT=0
I '$O(^PS(52.9,0)) W !!,"THE LABEL/PROFILE MONITOR LIST IS EMPTY.",!! Q
PT 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 PSOBR=$P(Y,"^") D RX08 G:$G(PSOBOUT) END S PSOBR1=PSOBR
RX2 S 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 ;K ZTSK,%ZIS S PSOIS=PSOIOS,%ZIS("A")="PRINT ON DEVICE: ",%ZIS("B")=$P(^%ZIS(1,PSOBPT,0),"^"),%ZIS="QMN" D ^%ZIS
;N PSOBAR1,PSOBAR0,PSOBARS,PSOIOS K %ZIS G:POP END S ZTIO=ION
S ZTIO=PSOLAP ;IHS/DSD/ENM 07/01/97
F J=0,1 S @("PSOBAR"_J)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J)) S @("PSOBAR"_J)=^("BAR"_J)
S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19) D LASK^PSOLSET
;I $E(IOST,1,3)="C-" W *7,!,"Output MUST be sent to a printer !!",! G SET
;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("APSPMAN"))="" ;IHS/DSD/ENM 5/1/95 APSPMAN VAR ADDED
;D ^%ZTLOAD I $G(ZTSK) W !,"Task Queued #"_ZTSK_" !!",!
D ^PSOBMST ;IHS/DSD/ENM 07/01/97
END D ^%ZISC K PSOIS,ZTSK,%ZIS,CC,DIC,IOP,I,POP,PSOB,PSOBIO,PSOBPT,PSOBR,PSOBR1,PSOBR2,PSOBRX,PSOBOUT,X,Y,APSPKEYZ 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(^(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 S:'$T!(X["^") PSOBOUT=1 Q:$G(PSOBOUT) D:X="?" LIST 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 ;IHS/DSD/ENM 09/4/97
APSPSOB ;BHAM/ISC/CCG - BLACK LINE RESOLVER [ 09/09/97 8:45 AM ]
+1 ;;6.0;OUTPATIENT PHARMACY;;09/03/97
+2 ;;6.0;OUTPATIENT PHARMACY;**31,78,101,143**;09/03/97
+3 ;IHS/DSD/ENM 07/01/97
SET APSPKEYZ=1
+4 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$GET(PSOPAR)
QUIT
+5 ;IHS/DSD/ENM 06/10/97
IF '$DATA(PSOIOS)
SET PSOIOS=IOS
+6 SET (CC,PSOCLC,PDUZ)=DUZ
SET PSOBOUT=0
+7 IF '$ORDER(^PS(52.9,0))
WRITE !!,"THE LABEL/PROFILE MONITOR LIST IS EMPTY.",!!
QUIT
PT 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 PSOBR=$PIECE(Y,"^")
DO RX08
IF $GET(PSOBOUT)
GOTO END
SET PSOBR1=PSOBR
RX2 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 ;K ZTSK,%ZIS S PSOIS=PSOIOS,%ZIS("A")="PRINT ON DEVICE: ",%ZIS("B")=$P(^%ZIS(1,PSOBPT,0),"^"),%ZIS="QMN" D ^%ZIS
+1 ;N PSOBAR1,PSOBAR0,PSOBARS,PSOIOS K %ZIS G:POP END S ZTIO=ION
+2 ;IHS/DSD/ENM 07/01/97
SET ZTIO=PSOLAP
+3 FOR J=0,1
SET @("PSOBAR"_J)=""
IF $DATA(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J))
SET @("PSOBAR"_J)=^("BAR"_J)
+4 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",19)
DO LASK^PSOLSET
+5 ;I $E(IOST,1,3)="C-" W *7,!,"Output MUST be sent to a printer !!",! G SET
+6 ;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"))=""
+7 ;S (ZTSAVE("PSOIOS"),ZTSAVE("PSOBAR0"),ZTSAVE("PSOBAR1"),ZTSAVE("PSOBARS"),ZTSAVE("PSOSYS"),ZTSAVE("APSPMAN"))="" ;IHS/DSD/ENM 5/1/95 APSPMAN VAR ADDED
+8 ;D ^%ZTLOAD I $G(ZTSK) W !,"Task Queued #"_ZTSK_" !!",!
+9 ;IHS/DSD/ENM 07/01/97
DO ^PSOBMST
END DO ^%ZISC
KILL PSOIS,ZTSK,%ZIS,CC,DIC,IOP,I,POP,PSOB,PSOBIO,PSOBPT,PSOBR,PSOBR1,PSOBR2,PSOBRX,PSOBOUT,X,Y,APSPKEYZ
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(^(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
IF $GET(PSOBOUT)
QUIT
IF X="?"
DO LIST
IF PSOB'[(U_X_"^")
WRITE !!,"???"
GOTO RX05
+1 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 ;W !,"CHOOSE 1-",I-2," : " R X:DTIME G:(X<1)!(X>(I-2)) RL S X=$P(PSOB,"^",X+1) Q ;IHS/DSD/ENM 09/4/97
