- PSOBMST ;BIR/LAW-black line resolver ;03/6/98
- ;;7.0;OUTPATIENT PHARMACY;**2,71,193,367**;DEC 1997;Build 62
- ;master program launched by psob
- S PSOBMST="",PSOBP1=+PSOBR1,PSOBR1=+$P(PSOBR1,"^",2),PSOBP2=+PSOBR2,PSOBR2=+$P(PSOBR2,"^",2),(NEW1,NEW11)="",PSOBRX=PSOBR1
- 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
- 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
- J 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
- Q
- SET 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)
- 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)
- Q
- PRF Q:(ZI=PSOBP2)&((PSOBR2=0)!($D(^PS(52.9,PSOBIO,1,ZI,2,PSOBR2,0)))) S:PSOBX'="" NEW1="^"_PSOBX S:PSOBX1'="" NEW11="^"_PSOBX1
- 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
- LBL 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)
- S IOP=IO,%ZIS="" D ^%ZIS K IOP D EN01
- F L=1:1 S LBL=$P(PPL,",",L) Q:(LBL="")&(L'<$L(PPL,",")) D UPDT
- I $G(PSOBX1)'="" S PSOBX=PSOBX1 S PSOBX1="" G LBL
- K PPL,PSOSITE,REPRINT,RXP,RXY,COPIES,SIDE Q
- UPDT ;
- 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
- S K=1,II=0 F JJ=0:0 S JJ=$O(^PSRX(LBL,"A",JJ)) Q:'JJ S II=JJ,K=K+1
- 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
- .I $G(PBXRF(LBL))>5,'$G(PSOBXPRT(LBL)) S $P(^PSRX(LBL,"A",II,0),"^",4)=($G(PBXRF(LBL))+1)
- EN01 I $D(PSOIOS),PSOIOS]"" D DEVBAR
- I $G(PSOBAR0)]"",$G(PSOBAR1)]"",$D(^PS(59,PSOSITE,1)) S PSOBARS=1
- K PSOCPN,PSOLBLCP
- I $G(PSODISP) D ^PSOLBL4
- G:'$D(PPL)!($P(PSOPAR,"^",30)=2) OUT
- F PI=1:1 Q:$P(PPL,",",PI)="" S RX=$P(PPL,",",PI) D
- .S PSOBLALL=1,RXRP(RX)=1_"^"_$G(COPIES)_"^"_$S($G(SIDE):1,1:0)
- .I $G(PSOMGREP) S RXRP(RX,"MG")=1
- .S:$G(PSOBXPRT(RX)) RXPR(RX)=PSOBXPRT(RX)
- .S:$D(PBXRF(RX)) RXFL(RX)=PBXRF(RX) D C^PSOLBL
- .K RXRP(+$G(PSOBLRX)),RXPR(+$G(PSOBLRX)),RXFL(+$G(PSOBLRX))
- .K PSOBLRX,RXP
- OUT K PSOCPN,PSOLBLCP,RXRP,RXPR,RXFL,PSOBLRX,RXP,RX
- Q
- DEVBAR ;get the barcode parameters
- N DA,DR,DPTR,DPTRS,DPTRS1,DIQ,DIC
- S DIC="^%ZIS(1,",DA=PSOIOS,DR="3",DIQ="DPTR",DIQ(0)="I" D EN^DIQ1
- S DPTRS=$G(DPTR(3.5,DA,3,DIQ(0)))
- S DIC="^%ZIS(2,",DA=DPTRS,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)))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBMST 3366 printed Jan 18, 2025@03:26:01 Page 2
- PSOBMST ;BIR/LAW-black line resolver ;03/6/98
- +1 ;;7.0;OUTPATIENT PHARMACY;**2,71,193,367**;DEC 1997;Build 62
- +2 ;master program launched by psob
- +3 SET PSOBMST=""
- SET PSOBP1=+PSOBR1
- SET PSOBR1=+$PIECE(PSOBR1,"^",2)
- SET PSOBP2=+PSOBR2
- SET PSOBR2=+$PIECE(PSOBR2,"^",2)
- SET (NEW1,NEW11)=""
- SET PSOBRX=PSOBR1
- +4 FOR ZI=PSOBP1-1:0
- SET ZI=$ORDER(^PS(52.9,PSOBIO,1,ZI))
- if ('ZI)!(PSOBP2<ZI)
- QUIT
- SET (PSOBX,PSOBX1)=""
- SET P=$SELECT($PIECE(^(ZI,0),"^",2)="P":U,1:",")
- DO J
- if (P=U)&(ZI'=PSOBP1)
- DO PRF
- if (P'=U)&(PSOBX'="")
- DO LBL
- SET PSOBRX=0
- +5 DO ^%ZISC
- KILL 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
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- J if '$DATA(^PS(52.9,PSOBIO,1,ZI,2))
- QUIT
- FOR J=PSOBRX:0
- SET J=$ORDER(^PS(52.9,PSOBIO,1,ZI,2,J))
- if ('J)!((ZI=PSOBP2)&(J=PSOBR2))
- QUIT
- DO SET
- +1 QUIT
- SET IF ($LENGTH(PSOBX)+$LENGTH(^PS(52.9,PSOBIO,1,ZI,2,J,0))+1)<245
- SET PSOBX=PSOBX_+^(0)_P
- if $PIECE(^(0),"^",2)
- SET PSOBXPRT($PIECE(^(0),"^"))=$PIECE(^(0),"^",2)
- if $PIECE(^(0),"^",3)'=""
- SET PBXRF($PIECE(^(0),"^"))=$PIECE(^(0),"^",3)
- +1 IF '$TEST
- SET PSOBX1=PSOBX1_+^PS(52.9,PSOBIO,1,ZI,2,J,0)_P
- if $PIECE(^(0),"^",2)
- SET PSOBXPRT($PIECE(^(0),"^"))=$PIECE(^(0),"^",2)
- if $PIECE(^(0),"^",3)'=""
- SET PBXRF($PIECE(^(0),"^"))=$PIECE(^(0),"^",3)
- +2 QUIT
- PRF if (ZI=PSOBP2)&((PSOBR2=0)!($DATA(^PS(52.9,PSOBIO,1,ZI,2,PSOBR2,0))))
- QUIT
- if PSOBX'=""
- SET NEW1="^"_PSOBX
- if PSOBX1'=""
- SET NEW11="^"_PSOBX1
- +1 SET DFN=$PIECE(^PS(52.9,PSOBIO,1,ZI,0),"^")
- SET PSODTCUT=$PIECE(^(0),"^",4)
- SET PSOPRPAS=$PIECE(^(0),"^",6)
- SET PFIO=IO
- SET %ZIS=""
- SET IOP=PFIO
- DO ^%ZIS
- DO START^PSOPRF
- SET (NEW1,NEW11)=""
- KILL DFN,PSODTCUT,PSOPRPAS,IOP
- QUIT
- LBL SET PPL=PSOBX
- SET PSOSITE=$PIECE(^PS(52.9,PSOBIO,1,ZI,0),"^",7)
- SET REPRINT=1
- if $PIECE(^(0),"^",5)'=""
- SET COPIES=$PIECE(^(0),"^",5)
- if $PIECE(^(0),"^",6)'=""
- SET SIDE=$PIECE(^(0),"^",6)
- IF $DATA(^(1))
- IF ^(1)'=""
- SET RXY=^(1)
- +1 SET IOP=IO
- SET %ZIS=""
- DO ^%ZIS
- KILL IOP
- DO EN01
- +2 FOR L=1:1
- SET LBL=$PIECE(PPL,",",L)
- if (LBL="")&(L'<$LENGTH(PPL,","))
- QUIT
- DO UPDT
- +3 IF $GET(PSOBX1)'=""
- SET PSOBX=PSOBX1
- SET PSOBX1=""
- GOTO LBL
- +4 KILL PPL,PSOSITE,REPRINT,RXP,RXY,COPIES,SIDE
- QUIT
- UPDT ;
- +1 SET BBB=0
- FOR BBBB=0:0
- SET BBBB=$ORDER(^PSRX(LBL,1,BBBB))
- if 'BBBB
- QUIT
- SET BBB=BBBB
- if BBBB>5
- SET BBB=BBBB+1
- +2 SET K=1
- SET II=0
- FOR JJ=0:0
- SET JJ=$ORDER(^PSRX(LBL,"A",JJ))
- if 'JJ
- QUIT
- SET II=JJ
- SET K=K+1
- +3 SET II=II+1
- if '($DATA(^PSRX(LBL,"A",0))#2)
- SET ^(0)="^52.3DA^^^"
- SET ^(0)=$PIECE(^(0),"^",1,2)_"^"_II_"^"_K
- SET ^PSRX(LBL,"A",II,0)=DT_"^W^"_PDUZ_"^"_$SELECT($GET(PSOBXPRT(LBL)):6,$DATA(PBXRF(LBL)):PBXRF(LBL),1:BBB)_"^"_"GROUP REPRINT"
- Begin DoDot:1
- +4 IF $GET(PBXRF(LBL))>5
- IF '$GET(PSOBXPRT(LBL))
- SET $PIECE(^PSRX(LBL,"A",II,0),"^",4)=($GET(PBXRF(LBL))+1)
- End DoDot:1
- QUIT
- EN01 IF $DATA(PSOIOS)
- IF PSOIOS]""
- DO DEVBAR
- +1 IF $GET(PSOBAR0)]""
- IF $GET(PSOBAR1)]""
- IF $DATA(^PS(59,PSOSITE,1))
- SET PSOBARS=1
- +2 KILL PSOCPN,PSOLBLCP
- +3 IF $GET(PSODISP)
- DO ^PSOLBL4
- +4 if '$DATA(PPL)!($PIECE(PSOPAR,"^",30)=2)
- GOTO OUT
- +5 FOR PI=1:1
- if $PIECE(PPL,",",PI)=""
- QUIT
- SET RX=$PIECE(PPL,",",PI)
- Begin DoDot:1
- +6 SET PSOBLALL=1
- SET RXRP(RX)=1_"^"_$GET(COPIES)_"^"_$SELECT($GET(SIDE):1,1:0)
- +7 IF $GET(PSOMGREP)
- SET RXRP(RX,"MG")=1
- +8 if $GET(PSOBXPRT(RX))
- SET RXPR(RX)=PSOBXPRT(RX)
- +9 if $DATA(PBXRF(RX))
- SET RXFL(RX)=PBXRF(RX)
- DO C^PSOLBL
- +10 KILL RXRP(+$GET(PSOBLRX)),RXPR(+$GET(PSOBLRX)),RXFL(+$GET(PSOBLRX))
- +11 KILL PSOBLRX,RXP
- End DoDot:1
- OUT KILL PSOCPN,PSOLBLCP,RXRP,RXPR,RXFL,PSOBLRX,RXP,RX
- +1 QUIT
- DEVBAR ;get the barcode parameters
- +1 NEW DA,DR,DPTR,DPTRS,DPTRS1,DIQ,DIC
- +2 SET DIC="^%ZIS(1,"
- SET DA=PSOIOS
- SET DR="3"
- SET DIQ="DPTR"
- SET DIQ(0)="I"
- DO EN^DIQ1
- +3 SET DPTRS=$GET(DPTR(3.5,DA,3,DIQ(0)))
- +4 SET DIC="^%ZIS(2,"
- SET DA=DPTRS
- SET DR="61;60"
- SET DIQ="DPTRS1"
- SET DIQ(0)="I"
- DO EN^DIQ1
- +5 SET PSOBAR0=""
- IF $GET(DPTRS1(3.2,DA,61,DIQ(0)))'=""
- SET PSOBAR0=$GET(DPTRS1(3.2,DA,61,DIQ(0)))
- +6 SET PSOBAR1=""
- IF $GET(DPTRS1(3.2,DA,60,DIQ(0)))'=""
- SET PSOBAR1=$GET(DPTRS1(3.2,DA,60,DIQ(0)))
- +7 QUIT