source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBMST.m@ 1535

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

initial load of FOIAVistA 6/30/08 version

File size: 3.2 KB
Line 
1PSOBMST ;BIR/LAW-black line resolver ;03/6/98
2 ;;7.0;OUTPATIENT PHARMACY;**2,71,193**;DEC 1997
3 ;master program launched by psob
4 S PSOBMST="",PSOBP1=+PSOBR1,PSOBR1=+$P(PSOBR1,"^",2),PSOBP2=+PSOBR2,PSOBR2=+$P(PSOBR2,"^",2),(NEW1,NEW11)="",PSOBRX=PSOBR1
5 F ZI=PSOBP1-1:0 S ZI=$O(^PS(52.9,PSOBIO,1,ZI)) Q:('ZI)!(PSOBP2<ZI) S (PSOBX,PSOBX1)="",P=$S($P(^(ZI,0),"^",2)="P":U,1:",") D J D PRF:(P=U)&(ZI'=PSOBP1),LBL:(P'=U)&(PSOBX'="") S PSOBRX=0
6 D ^%ZISC K CC,EXDT,I,II,IOP,J,JJ,K,L,LBL,NEW1,NEW11,P,PI,POP,PPL,PSCAP,PSOSITE,PSOBIO,PSOBMST,PSOBP1,PSOBP2,PSOBR1,PSOBR2,PSOBRX,PSOBX,PSOBLALL,PSOBX1,REF,RX,WARN,X,Y,ZI,ZY,%ZIS,PSODIV,PDUZ,PSOBXPRT,BBB,BBBB,PBXRF S:$D(ZTQUEUED) ZTREQ="@" Q
7J Q:'$D(^PS(52.9,PSOBIO,1,ZI,2)) F J=PSOBRX:0 S J=$O(^PS(52.9,PSOBIO,1,ZI,2,J)) Q:('J)!((ZI=PSOBP2)&(J=PSOBR2)) D SET
8 Q
9SET I ($L(PSOBX)+$L(^PS(52.9,PSOBIO,1,ZI,2,J,0))+1)<245 S PSOBX=PSOBX_+^(0)_P S:$P(^(0),"^",2) PSOBXPRT($P(^(0),"^"))=$P(^(0),"^",2) S:$P(^(0),"^",3)'="" PBXRF($P(^(0),"^"))=$P(^(0),"^",3)
10 E S PSOBX1=PSOBX1_+^PS(52.9,PSOBIO,1,ZI,2,J,0)_P S:$P(^(0),"^",2) PSOBXPRT($P(^(0),"^"))=$P(^(0),"^",2) S:$P(^(0),"^",3)'="" PBXRF($P(^(0),"^"))=$P(^(0),"^",3)
11 Q
12PRF Q:(ZI=PSOBP2)&((PSOBR2=0)!($D(^PS(52.9,PSOBIO,1,ZI,2,PSOBR2,0)))) S:PSOBX'="" NEW1="^"_PSOBX S:PSOBX1'="" NEW11="^"_PSOBX1
13 S DFN=$P(^PS(52.9,PSOBIO,1,ZI,0),"^"),PSODTCUT=$P(^(0),"^",4),PSOPRPAS=$P(^(0),"^",6),PFIO=IO,%ZIS="",IOP=PFIO D ^%ZIS D START^PSOPRF S (NEW1,NEW11)="" K DFN,PSODTCUT,PSOPRPAS,IOP Q
14LBL S PPL=PSOBX,PSOSITE=$P(^PS(52.9,PSOBIO,1,ZI,0),"^",7),REPRINT=1 S:$P(^(0),"^",5)'="" COPIES=$P(^(0),"^",5) S:$P(^(0),"^",6)'="" SIDE=$P(^(0),"^",6) I $D(^(1)),^(1)'="" S RXY=^(1)
15 S IOP=IO,%ZIS="" D ^%ZIS K IOP D EN01
16 F L=1:1 S LBL=$P(PPL,",",L) Q:(LBL="")&(L'<$L(PPL,",")) D UPDT
17 I $G(PSOBX1)'="" S PSOBX=PSOBX1 S PSOBX1="" G LBL
18 K PPL,PSOSITE,REPRINT,RXP,RXY,COPIES,SIDE Q
19UPDT ;
20 S BBB=0 F BBBB=0:0 S BBBB=$O(^PSRX(LBL,1,BBBB)) Q:'BBBB S BBB=BBBB S:BBBB>5 BBB=BBBB+1
21 S K=1,II=0 F JJ=0:0 S JJ=$O(^PSRX(LBL,"A",JJ)) Q:'JJ S II=JJ,K=K+1
22 S II=II+1 S:'($D(^PSRX(LBL,"A",0))#2) ^(0)="^52.3DA^^^" S ^(0)=$P(^(0),"^",1,2)_"^"_II_"^"_K,^PSRX(LBL,"A",II,0)=DT_"^W^"_PDUZ_"^"_$S($G(PSOBXPRT(LBL)):6,$D(PBXRF(LBL)):PBXRF(LBL),1:BBB)_"^"_"GROUP REPRINT" D Q
23 .I $G(PBXRF(LBL))>5,'$G(PSOBXPRT(LBL)) S $P(^PSRX(LBL,"A",II,0),"^",4)=($G(PBXRF(LBL))+1)
24EN01 I $D(PSOIOS),PSOIOS]"" D DEVBAR
25 I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1
26 K PSOCPN,PSOLBLCP
27 I $G(PSODISP) D ^PSOLBL4
28 G:'$D(PPL)!($P(PSOPAR,"^",30)=2) OUT
29 F PI=1:1 Q:$P(PPL,",",PI)="" S RX=$P(PPL,",",PI) D
30 .S PSOBLALL=1,RXRP(RX)=1_"^"_$G(COPIES)_"^"_$S($G(SIDE):1,1:0)
31 .S:$G(PSOBXPRT(RX)) RXPR(RX)=PSOBXPRT(RX)
32 .S:$D(PBXRF(RX)) RXFL(RX)=PBXRF(RX) D C^PSOLBL
33 .K RXRP(+$G(PSOBLRX)),RXPR(+$G(PSOBLRX)),RXFL(+$G(PSOBLRX))
34 .K PSOBLRX,RXP
35OUT K PSOCPN,PSOLBLCP,RXRP,RXPR,RXFL,PSOBLRX,RXP,RX
36 Q
37DEVBAR ;get the barcode parameters
38 N DA,DR,DPTR,DPTRS,DPTRS1,DIQ,DIC
39 S DIC="^%ZIS(1,",DA=PSOIOS,DR="3",DIQ="DPTR",DIQ(0)="I" D EN^DIQ1
40 S DPTRS=$G(DPTR(3.5,DA,3,DIQ(0)))
41 S DIC="^%ZIS(2,",DA=DPTRS,DR="61;60",DIQ="DPTRS1",DIQ(0)="I" D EN^DIQ1
42 S PSOBAR0="" I $G(DPTRS1(3.2,DA,61,DIQ(0)))'="" S PSOBAR0=$G(DPTRS1(3.2,DA,61,DIQ(0)))
43 S PSOBAR1="" I $G(DPTRS1(3.2,DA,60,DIQ(0)))'="" S PSOBAR1=$G(DPTRS1(3.2,DA,60,DIQ(0)))
44 Q
Note: See TracBrowser for help on using the repository browser.