PSOBSET1 ;BHAM ISC/CCG - BLACK LINE RESOLVER ; 10/24/92 13:23
;;7.0;OUTPATIENT PHARMACY;**268**;DEC 1997;Build 9
S PSOBMX=$P(^PS(59,PSOBPS,0),"^",9) S:+PSOBMX<1000 PSOBMX=1000,^PS(59,PSOBPS,0)=$P(^(0),"^",1,8)_"^1000^"_$P(^(0),"^",10,255)
LCK L +^PS(52.9,PSOBIO,1,0):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) G:'$T LCK S Z=$P(^PS(52.9,PSOBIO,1,0),"^",3),ZX=$P(^(0),"^",4)
LP S Z=Z+1,ZX=ZX+1 G:$D(^PS(52.9,PSOBIO,1,Z,0)) LP D:(ZX>PSOBMX)&($D(^PS(52.9,PSOBIO,1,Z-PSOBMX))) DEL S ^PS(52.9,PSOBIO,1,0)=$P(^PS(52.9,PSOBIO,1,0),"^",1,2)_"^"_Z_"^"_ZX L -^PS(52.9,PSOBIO,1,0) S %DT="T",X="N" D ^%DT
S ^PS(52.9,PSOBIO,1,Z,0)=PSOBDPT_"^"_PSOBR_"^"_Y_"^"_$G(RXP)_"^"_PSOBCP_"^"_PSOBVR2_"^"_PSOBPS,^PS(52.9,PSOBIO,1,"B",PSOBDPT,Z)="",PSOB=0
S PSOBPCZ=PSOBPC F P=1:1:$L(^PSOBPPL($J)) I $E(^PSOBPPL($J),P)'?.AN,$E(^($J),P)'="*" S PSOBPC=$E(^($J),P) Q
PPL F P=1:1 Q:($P(^PSOBPPL($J),PSOBPC,P)="")&(P'=1) S PSOBRX=$P($P(^PSOBPPL($J),PSOBPC,P),"*",1) D:PSOBRX'="" C
I $D(PSOBPPL1),PSOBPPL1'="" S ^PSOBPPL($J)=PSOBPPL1 K PSOBPPL1 G PPL
I PSOB S ^PS(52.9,PSOBIO,1,Z,2,0)="^52.9002P^"_PSOB_"^"_PSOB
I +$P(^PS(52.9,PSOBIO,1,0),"^",3)=0 K ^PS(52.9,"B",^PS(52.9,PSOBIO,0),PSOBIO),^PS(52.9,PSOBIO) S ^PS(52.9,0)=$P(^PS(52.9,0),"^",1,2)_"^"_($P(^(0),"^",3)-1)_"^"_($P(^(0),"^",4)-1)
Q S:$D(PSOBPCZ) PSOBPC=PSOBPCZ K PSOBPCZ K:'$D(PSOBS) I,IOP,PSOBPPL1,PSOBR,PSOBPC,PSOBPS,^PSOBPPL($J),PSOB,PSOBIO,PSOBRX,PSOBDPT,PSOBCP,PSOBVR2,PSOBVR1,PSOBZ,PSOBMX,X,Y,Z,ZZX,ZX,P,%ZIS,%ZIS("B")
Q
C Q:'$D(^PSRX(PSOBRX,0)) S PSOB=PSOB+1,^PS(52.9,PSOBIO,1,Z,2,PSOB,0)=PSOBRX,^PS(52.9,PSOBIO,1,"C",PSOBRX,Z,PSOB)="" S:$G(RXPR(PSOBRX)) $P(^PS(52.9,PSOBIO,1,Z,2,PSOB,0),"^",2)=$G(RXPR(PSOBRX))
S:$D(RXFL(PSOBRX)) $P(^PS(52.9,PSOBIO,1,Z,2,PSOB,0),"^",3)=$G(RXFL(PSOBRX)) Q
DEL S ZZX=Z-PSOBMX F I=0:0 S I=$O(^PS(52.9,PSOBIO,1,ZZX,2,I)) Q:'I K ^PS(52.9,PSOBIO,1,"C",^PS(52.9,PSOBIO,1,ZZX,2,I,0),ZZX)
S PSOBZ=$P(^PS(52.9,PSOBIO,1,ZZX,0),"^") K ^PS(52.9,PSOBIO,1,"B",+PSOBZ,ZZX),^PS(52.9,PSOBIO,1,ZZX) S ZX=ZX-1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBSET1 1998 printed Jun 11, 2024@22:19:14 Page 2
PSOBSET1 ;BHAM ISC/CCG - BLACK LINE RESOLVER ; 10/24/92 13:23
+1 ;;7.0;OUTPATIENT PHARMACY;**268**;DEC 1997;Build 9
+2 SET PSOBMX=$PIECE(^PS(59,PSOBPS,0),"^",9)
if +PSOBMX<1000
SET PSOBMX=1000
SET ^PS(59,PSOBPS,0)=$PIECE(^(0),"^",1,8)_"^1000^"_$PIECE(^(0),"^",10,255)
LCK LOCK +^PS(52.9,PSOBIO,1,0):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
if '$TEST
GOTO LCK
SET Z=$PIECE(^PS(52.9,PSOBIO,1,0),"^",3)
SET ZX=$PIECE(^(0),"^",4)
LP SET Z=Z+1
SET ZX=ZX+1
if $DATA(^PS(52.9,PSOBIO,1,Z,0))
GOTO LP
if (ZX>PSOBMX)&($DATA(^PS(52.9,PSOBIO,1,Z-PSOBMX)))
DO DEL
SET ^PS(52.9,PSOBIO,1,0)=$PIECE(^PS(52.9,PSOBIO,1,0),"^",1,2)_"^"_Z_"^"_ZX
LOCK -^PS(52.9,PSOBIO,1,0)
SET %DT="T"
SET X="N"
DO ^%DT
+1 SET ^PS(52.9,PSOBIO,1,Z,0)=PSOBDPT_"^"_PSOBR_"^"_Y_"^"_$GET(RXP)_"^"_PSOBCP_"^"_PSOBVR2_"^"_PSOBPS
SET ^PS(52.9,PSOBIO,1,"B",PSOBDPT,Z)=""
SET PSOB=0
+2 SET PSOBPCZ=PSOBPC
FOR P=1:1:$LENGTH(^PSOBPPL($JOB))
IF $EXTRACT(^PSOBPPL($JOB),P)'?.AN
IF $EXTRACT(^($JOB),P)'="*"
SET PSOBPC=$EXTRACT(^($JOB),P)
QUIT
PPL FOR P=1:1
if ($PIECE(^PSOBPPL($JOB),PSOBPC,P)="")&(P'=1)
QUIT
SET PSOBRX=$PIECE($PIECE(^PSOBPPL($JOB),PSOBPC,P),"*",1)
if PSOBRX'=""
DO C
+1 IF $DATA(PSOBPPL1)
IF PSOBPPL1'=""
SET ^PSOBPPL($JOB)=PSOBPPL1
KILL PSOBPPL1
GOTO PPL
+2 IF PSOB
SET ^PS(52.9,PSOBIO,1,Z,2,0)="^52.9002P^"_PSOB_"^"_PSOB
+3 IF +$PIECE(^PS(52.9,PSOBIO,1,0),"^",3)=0
KILL ^PS(52.9,"B",^PS(52.9,PSOBIO,0),PSOBIO),^PS(52.9,PSOBIO)
SET ^PS(52.9,0)=$PIECE(^PS(52.9,0),"^",1,2)_"^"_($PIECE(^(0),"^",3)-1)_"^"_($PIECE(^(0),"^",4)-1)
Q if $DATA(PSOBPCZ)
SET PSOBPC=PSOBPCZ
KILL PSOBPCZ
if '$DATA(PSOBS)
KILL I,IOP,PSOBPPL1,PSOBR,PSOBPC,PSOBPS,^PSOBPPL($JOB),PSOB,PSOBIO,PSOBRX,PSOBDPT,PSOBCP,PSOBVR2,PSOBVR1,PSOBZ,PSOBMX,X,Y,Z,ZZX,ZX,P,%ZIS,%ZIS("B")
+1 QUIT
C if '$DATA(^PSRX(PSOBRX,0))
QUIT
SET PSOB=PSOB+1
SET ^PS(52.9,PSOBIO,1,Z,2,PSOB,0)=PSOBRX
SET ^PS(52.9,PSOBIO,1,"C",PSOBRX,Z,PSOB)=""
if $GET(RXPR(PSOBRX))
SET $PIECE(^PS(52.9,PSOBIO,1,Z,2,PSOB,0),"^",2)=$GET(RXPR(PSOBRX))
+1 if $DATA(RXFL(PSOBRX))
SET $PIECE(^PS(52.9,PSOBIO,1,Z,2,PSOB,0),"^",3)=$GET(RXFL(PSOBRX))
QUIT
DEL SET ZZX=Z-PSOBMX
FOR I=0:0
SET I=$ORDER(^PS(52.9,PSOBIO,1,ZZX,2,I))
if 'I
QUIT
KILL ^PS(52.9,PSOBIO,1,"C",^PS(52.9,PSOBIO,1,ZZX,2,I,0),ZZX)
+1 SET PSOBZ=$PIECE(^PS(52.9,PSOBIO,1,ZZX,0),"^")
KILL ^PS(52.9,PSOBIO,1,"B",+PSOBZ,ZZX),^PS(52.9,PSOBIO,1,ZZX)
SET ZX=ZX-1
QUIT
