- 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 Feb 18, 2025@23:51:36 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
