PSOBMST ;BIR/LAW-black line resolver ;29-May-2012 14:39;PLS
;;7.0;OUTPATIENT PHARMACY;**2,71,193,1015**;DEC 1997;Build 62
;master program launched by psob
; Modified - IHS/CIA/PLS - 01/16/04 - Line EN01+2
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
; IHS/CIA/PLS - 01/16/04 - Added call to IHS label generator.
F PI=1:1 Q:$P(PPL,",",PI)="" S RX=$P(PPL,",",PI) S PSOBLALL=1 D PARM^APSPLBL,C^APSPLBL
G OUT ;IHS/MSC/PLS - 5/10/2010 - Added jump in patch 1010
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)
.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
PSOBMST ;BIR/LAW-black line resolver ;29-May-2012 14:39;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**2,71,193,1015**;DEC 1997;Build 62
+2 ;master program launched by psob
+3 ; Modified - IHS/CIA/PLS - 01/16/04 - Line EN01+2
+4 SET PSOBMST=""
SET PSOBP1=+PSOBR1
SET PSOBR1=+$PIECE(PSOBR1,"^",2)
SET PSOBP2=+PSOBR2
SET PSOBR2=+$PIECE(PSOBR2,"^",2)
SET (NEW1,NEW11)=""
SET PSOBRX=PSOBR1
+5 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
+6 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 ; IHS/CIA/PLS - 01/16/04 - Added call to IHS label generator.
+6 FOR PI=1:1
IF $PIECE(PPL,",",PI)=""
QUIT
SET RX=$PIECE(PPL,",",PI)
SET PSOBLALL=1
DO PARM^APSPLBL
DO C^APSPLBL
+7 ;IHS/MSC/PLS - 5/10/2010 - Added jump in patch 1010
GOTO OUT
+8 FOR PI=1:1
IF $PIECE(PPL,",",PI)=""
QUIT
SET RX=$PIECE(PPL,",",PI)
Begin DoDot:1
+9 SET PSOBLALL=1
SET RXRP(RX)=1_"^"_$GET(COPIES)_"^"_$SELECT($GET(SIDE):1,1:0)
+10 IF $GET(PSOBXPRT(RX))
SET RXPR(RX)=PSOBXPRT(RX)
+11 IF $DATA(PBXRF(RX))
SET RXFL(RX)=PBXRF(RX)
DO C^PSOLBL
+12 KILL RXRP(+$GET(PSOBLRX)),RXPR(+$GET(PSOBLRX)),RXFL(+$GET(PSOBLRX))
+13 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
