- 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
