PSOBSET ;BHAM ISC/CCG - BLACK LINE RESOLVER ; 10/24/92 13:23
;;7.0;OUTPATIENT PHARMACY;**10,268**;DEC 1997;Build 9
ENLBL ;SET UP ^PS(52.9 ENTRY FROM ^PSOLBL
K ^PSOBPPL($J)
S ^PSOBPPL($J)=PPL,PSOBPC="," G:^PSOBPPL($J)="" Q^PSOBSET1 S ZZX=0 D IO G:ZZX Q^PSOBSET1 S PSOBPS=PSOSITE G:PSOBPS="" Q^PSOBSET1 G:'$D(^PS(59,PSOBPS,0)) Q^PSOBSET1
S PSOBVR1=$G(RXP),PSOBCP=$G(COPIES),PSOBVR2=$G(SIDE),PSOBR="L"
LP S P=P+1,PSOBRX=$P(^PSOBPPL($J),",",P),PSOBVR1=$P(PSOBRX,"*",2),PSOBRX=$P(PSOBRX,"*",1) G:PSOBRX="" Q^PSOBSET1 G:'$D(^PSRX(PSOBRX,0)) LP S PSOBDPT=$P(^PSRX(PSOBRX,0),"^",2) G ^PSOBSET1
NWIO L +^PS(52.9,0):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) G:'$T NWIO S Z=$P(^PS(52.9,0),"^",3),ZX=$P(^(0),"^",4)
LP3 S Z=Z+1,ZX=ZX+1 G:$D(^PS(52.9,Z,0)) LP3 S ^PS(52.9,0)=$P(^PS(52.9,0),"^",1,2)_"^"_Z_"^"_ZX L -^PS(52.9,0) S ^PS(52.9,Z,0)=PSOBIO,^PS(52.9,Z,1,0)="^52.9001PI^^",^PS(52.9,"B",PSOBIO,Z)="" Q
IO I $D(IOS),IOS]"" G IO1
S IOP=IO,%ZIS="N",ZZX=1 D ^%ZIS K IOP Q:ION=""
IO1 S PSOBIO=IOS
D:'$D(^PS(52.9,"B",PSOBIO)) NWIO S PSOBIO=$O(^PS(52.9,"B",PSOBIO,0)),(ZZX,P)=0,(PSOBVR1,PSOBCP,PSOBVR2)="" Q
GP S PSOBR="P" G ^PSOBSET1
EN1P S ZZX=0 D IO G:ZZX Q^PSOBSET1 S PSOBPC=",",PSOBPS=PSOSITE,PSOBDPT=DFN,(^PSOBPPL($J),PSOBPPL1)="" S:$D(PSODTCUT) PSOBVR1=PSODTCUT S:$D(PSOPRPAS) PSOBVR2=PSOPRPAS S:$D(NEW1) ^PSOBPPL($J)=NEW1 S:$D(NEW11) PSOBPPL1=NEW11 G GP
SSUS S ZZX=0 D IO G:ZZX Q^PSOBSET1 S PSOBPS=PSOSITE,PSOBR="L",PSOBS="",PSOBII=0,PSOBPC="," K ZRXP
F ZII=0:0 S ZII=$O(^TMP($J,"PSOSU",XAK,ZII)) Q:'ZII S RX=^(ZII),PSOBVR1=$P(RX,"^",5),ZZRXP=$P(RX,"^",3),RX=+RX D S1
S0 I 'PSOBII F ZII=0:0 S ZII=$O(^PSOBPPL($J,ZII)) Q:'ZII S:^PSOBPPL($J,ZII)'="" PSOBVR1=^PSOBPPL($J,ZII) S ^PSOBPPL($J)=^PSOBPPL($J,ZII,1),P=0 D LP
K ZRXP,ZZRXP,PSOBII,RX,PSOBPS,PSOBS G Q^PSOBSET1
S1 I $D(ZRXP),ZZRXP=ZRXP G S2
S PSOBII=PSOBII+1,^PSOBPPL($J,PSOBII,1)="",^PSOBPPL($J,PSOBII)=ZZRXP
S2 S ZRXP=ZZRXP,^PSOBPPL($J,PSOBII,1)=^PSOBPPL($J,PSOBII,1)_RX_"*"_PSOBVR1_"," Q
SUS S ZZX=0 D IO G:ZZX Q^PSOBSET1 S PSOBPS=PSOSITE,PSOBR="L",PSOBS="",PSOBII=0,PSOBPC="," K ZRXP
F ZII=0:0 S ZII=$O(^PS(52.5,"C",ZI,ZII)) Q:'ZII I $D(^PS(52.5,ZII,0)),+$P(^(0),"^",6)=PSOSITE,'$D(^("P")) S RX=^(0),ZZRXP=$P(RX,"^",3),PSOBVR1=$P(RX,"^",5),RX=+RX D S1
G S0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBSET 2254 printed Dec 13, 2024@02:25:08 Page 2
PSOBSET ;BHAM ISC/CCG - BLACK LINE RESOLVER ; 10/24/92 13:23
+1 ;;7.0;OUTPATIENT PHARMACY;**10,268**;DEC 1997;Build 9
ENLBL ;SET UP ^PS(52.9 ENTRY FROM ^PSOLBL
+1 KILL ^PSOBPPL($JOB)
+2 SET ^PSOBPPL($JOB)=PPL
SET PSOBPC=","
if ^PSOBPPL($JOB)=""
GOTO Q^PSOBSET1
SET ZZX=0
DO IO
if ZZX
GOTO Q^PSOBSET1
SET PSOBPS=PSOSITE
if PSOBPS=""
GOTO Q^PSOBSET1
if '$DATA(^PS(59,PSOBPS,0))
GOTO Q^PSOBSET1
+3 SET PSOBVR1=$GET(RXP)
SET PSOBCP=$GET(COPIES)
SET PSOBVR2=$GET(SIDE)
SET PSOBR="L"
LP SET P=P+1
SET PSOBRX=$PIECE(^PSOBPPL($JOB),",",P)
SET PSOBVR1=$PIECE(PSOBRX,"*",2)
SET PSOBRX=$PIECE(PSOBRX,"*",1)
if PSOBRX=""
GOTO Q^PSOBSET1
if '$DATA(^PSRX(PSOBRX,0))
GOTO LP
SET PSOBDPT=$PIECE(^PSRX(PSOBRX,0),"^",2)
GOTO ^PSOBSET1
NWIO LOCK +^PS(52.9,0):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
if '$TEST
GOTO NWIO
SET Z=$PIECE(^PS(52.9,0),"^",3)
SET ZX=$PIECE(^(0),"^",4)
LP3 SET Z=Z+1
SET ZX=ZX+1
if $DATA(^PS(52.9,Z,0))
GOTO LP3
SET ^PS(52.9,0)=$PIECE(^PS(52.9,0),"^",1,2)_"^"_Z_"^"_ZX
LOCK -^PS(52.9,0)
SET ^PS(52.9,Z,0)=PSOBIO
SET ^PS(52.9,Z,1,0)="^52.9001PI^^"
SET ^PS(52.9,"B",PSOBIO,Z)=""
QUIT
IO IF $DATA(IOS)
IF IOS]""
GOTO IO1
+1 SET IOP=IO
SET %ZIS="N"
SET ZZX=1
DO ^%ZIS
KILL IOP
if ION=""
QUIT
IO1 SET PSOBIO=IOS
+1 if '$DATA(^PS(52.9,"B",PSOBIO))
DO NWIO
SET PSOBIO=$ORDER(^PS(52.9,"B",PSOBIO,0))
SET (ZZX,P)=0
SET (PSOBVR1,PSOBCP,PSOBVR2)=""
QUIT
GP SET PSOBR="P"
GOTO ^PSOBSET1
EN1P SET ZZX=0
DO IO
if ZZX
GOTO Q^PSOBSET1
SET PSOBPC=","
SET PSOBPS=PSOSITE
SET PSOBDPT=DFN
SET (^PSOBPPL($JOB),PSOBPPL1)=""
if $DATA(PSODTCUT)
SET PSOBVR1=PSODTCUT
if $DATA(PSOPRPAS)
SET PSOBVR2=PSOPRPAS
if $DATA(NEW1)
SET ^PSOBPPL($JOB)=NEW1
if $DATA(NEW11)
SET PSOBPPL1=NEW11
GOTO GP
SSUS SET ZZX=0
DO IO
if ZZX
GOTO Q^PSOBSET1
SET PSOBPS=PSOSITE
SET PSOBR="L"
SET PSOBS=""
SET PSOBII=0
SET PSOBPC=","
KILL ZRXP
+1 FOR ZII=0:0
SET ZII=$ORDER(^TMP($JOB,"PSOSU",XAK,ZII))
if 'ZII
QUIT
SET RX=^(ZII)
SET PSOBVR1=$PIECE(RX,"^",5)
SET ZZRXP=$PIECE(RX,"^",3)
SET RX=+RX
DO S1
S0 IF 'PSOBII
FOR ZII=0:0
SET ZII=$ORDER(^PSOBPPL($JOB,ZII))
if 'ZII
QUIT
if ^PSOBPPL($JOB,ZII)'=""
SET PSOBVR1=^PSOBPPL($JOB,ZII)
SET ^PSOBPPL($JOB)=^PSOBPPL($JOB,ZII,1)
SET P=0
DO LP
+1 KILL ZRXP,ZZRXP,PSOBII,RX,PSOBPS,PSOBS
GOTO Q^PSOBSET1
S1 IF $DATA(ZRXP)
IF ZZRXP=ZRXP
GOTO S2
+1 SET PSOBII=PSOBII+1
SET ^PSOBPPL($JOB,PSOBII,1)=""
SET ^PSOBPPL($JOB,PSOBII)=ZZRXP
S2 SET ZRXP=ZZRXP
SET ^PSOBPPL($JOB,PSOBII,1)=^PSOBPPL($JOB,PSOBII,1)_RX_"*"_PSOBVR1_","
QUIT
SUS SET ZZX=0
DO IO
if ZZX
GOTO Q^PSOBSET1
SET PSOBPS=PSOSITE
SET PSOBR="L"
SET PSOBS=""
SET PSOBII=0
SET PSOBPC=","
KILL ZRXP
+1 FOR ZII=0:0
SET ZII=$ORDER(^PS(52.5,"C",ZI,ZII))
if 'ZII
QUIT
IF $DATA(^PS(52.5,ZII,0))
IF +$PIECE(^(0),"^",6)=PSOSITE
IF '$DATA(^("P"))
SET RX=^(0)
SET ZZRXP=$PIECE(RX,"^",3)
SET PSOBVR1=$PIECE(RX,"^",5)
SET RX=+RX
DO S1
+2 GOTO S0
