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

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1PSOB ;BHAM ISC/CCG - black line resolver ; 07/18/96 8:49 am
2 ;;7.0;OUTPATIENT PHARMACY;**10,60,193**;DEC 1997
3 I '$D(PSOPAR) D ^PSOLSET Q:'$G(PSOPAR)
4 S (CC,PSOCLC,PDUZ)=DUZ,PSOBOUT=0
5 N PSODISP
6 I '$O(^PS(52.9,0)) W !!,"THE LABEL/PROFILE MONITOR LIST IS EMPTY.",!! Q
7 I $P(PSOPAR,"^",30),$$GET1^DIQ(59,PSOSITE_",",105,"I")=2.4 D
8 .K DIR,DIRUT S DIR("A")="Do you want to resend to Dispensing System Device",DIR(0)="Y",DIR("B")="No"
9 .D ^DIR K DIR I $D(DIRUT) K DIRUT Q
10 .S PSODISP=Y
11PT 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)
12RX1 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
13 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
14 .S PSOBR=+PSOBPT,Y(0)=PSODPT(0),Y(0,0)=PSODPT,Y=+PSOBY_"^"_$P(Y,"^",2) D RX08 S PSOBR1=PSOBR K DIC
15 S PSOBR=+Y D RX08 G:$G(PSOBOUT) END S PSOBR1=PSOBR
16RX2 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
17 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
18 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
19SET N PSOBAR1,PSOBAR0,PSOBARS,IOS
20 K ZTSK,%ZIS S DIC="^%ZIS(1,",(PSOIOS,DA)=PSOBPT,DR=".01;3",DIQ="DPTR",DIQ(0)="I" D EN^DIQ1
21 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
22 K %ZIS G:POP END
23 I $E(IOST,1,2)="C-" W $C(7),!,"Output MUST be sent to a printer !!",! G SET
24 S ZTIO=ION,PSOIOS=IOS,DA=IOST(0)
25 S DIC="^%ZIS(2,",DR="61;60",DIQ="DPTRS1",DIQ(0)="I" D EN^DIQ1
26 S PSOBAR0="" I $G(DPTRS1(3.2,DA,61,DIQ(0)))'="" S PSOBAR0=$G(DPTRS1(3.2,DA,61,DIQ(0)))
27 S PSOBAR1="" I $G(DPTRS1(3.2,DA,60,DIQ(0)))'="" S PSOBAR1=$G(DPTRS1(3.2,DA,60,DIQ(0)))
28 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19) S PSOBFLAG=1 D LASK^PSOLSET K PSOBFLAG
29 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"))=""
30 S (ZTSAVE("PSOIOS"),ZTSAVE("PSOBAR0"),ZTSAVE("PSOBAR1"),ZTSAVE("PSOBARS"),ZTSAVE("PSOSYS"))="",ZTSAVE("PSODISP")=""
31 D ^%ZTLOAD I $G(ZTSK) W !,"Task Queued #"_ZTSK_" !!",!
32END 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
33RX08 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)
34 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)
35 Q:($P(PSOBR,"^",2))!('$D(^PS(52.9,PSOBIO,1,+PSOBR,2,0)))
36 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),"^")_"^"
37 I $P(PSOB,"^",3)="" S PSOBR=+PSOBR_"^"_$P(^PS(52.9,PSOBIO,1,+PSOBR,2,0),"^",3) Q
38 I $P(Y(0),"^",2)="P" S PSOBR=+PSOBR_"^" Q
39RX05 W !,"ENTER RX# OF LAST USABLE SCRIPT FOR "_$P(^DPT(+Y(0),0),"^")_": " R X:DTIME I '$T!(X["^") S PSOBOUT=1 Q
40 D:X="?" LIST G:"^"[X RX05 I PSOB'[(U_X_"^") W !!,"???" G RX05
41 S PSOBR=+PSOBR_"^"_($O(^PS(52.9,PSOBIO,1,"C",$O(^PSRX("B",X,0)),+PSOBR,0))) Q
42LIST W !! F I=2:1 Q:$P(PSOB,"^",I)="" W !,?5,I-1," ",$P(PSOB,"^",I)
43RL W !,"CHOOSE 1-",I-2," : " R X:DTIME G:(X<1)!(X>(I-2)) RL S X=$P(PSOB,"^",X+1) Q
Note: See TracBrowser for help on using the repository browser.