source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOB.m@ 1397

PSOB ;BHAM ISC/CCG - black line resolver ; 07/18/96  8:49 am
 ;;7.0;OUTPATIENT PHARMACY;**10,60,193**;DEC 1997
 I '$D(PSOPAR) D ^PSOLSET Q:'$G(PSOPAR)
 S (CC,PSOCLC,PDUZ)=DUZ,PSOBOUT=0
 N PSODISP
 I '$O(^PS(52.9,0)) W !!,"THE LABEL/PROFILE MONITOR LIST IS EMPTY.",!! Q
 I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D
 .K DIR,DIRUT 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) K DIRUT Q
 .S PSODISP=Y
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 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
 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")=""
 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