44 lines
3.8 KiB
Mathematica
44 lines
3.8 KiB
Mathematica
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
|