PSOSUSRP ;BHAM ISC/RTR-Reprint label driver routine ;SEP 30, 2020@13:11
;;7.0;OUTPATIENT PHARMACY;**354,627**;DEC 1997;Build 2
;
BEG ;
G:'$D(^UTILITY($J,"PSOREPT")) END
S (PATIFLAG,RECOUNT)=0
N PSOREDEV,RXRP S PSOREDEV=$G(ZTIO)
F AAAA=0:0 S AAAA=$O(^UTILITY($J,"PSOREPT",AAAA)) Q:'AAAA F BBBB=0:0 S BBBB=$O(^UTILITY($J,"PSOREPT",AAAA,BBBB)) Q:'BBBB F CCCC=0:0 S CCCC=$O(^UTILITY($J,"PSOREPT",AAAA,BBBB,CCCC)) Q:'CCCC D
.F DDDD=0:0 S DDDD=$O(^PS(52.5,"AS",AAAA,BBBB,CCCC,DDDD)) Q:'DDDD F EEEE=0:0 S EEEE=$O(^PS(52.5,"AS",AAAA,BBBB,CCCC,DDDD,EEEE)) Q:'EEEE D:$D(^PS(52.5,EEEE,0))&($P($G(^(0)),"^"))&($P($G(^(0)),"^",3))
..S DFN=$P(^PS(52.5,EEEE,0),"^",3) D DEM^VADPT S HLDDEAD=VADM(6) K VADM,VA("PID"),VA("BID"),DFN I HLDDEAD'="" S DA=EEEE,DIK="^PS(52.5," D ^DIK Q
..I 'PATIFLAG S OPATIENT=$P(^PS(52.5,EEEE,0),"^",3),PATIFLAG=1
..S NPATIENT=$P(^PS(52.5,EEEE,0),"^",3) D:OPATIENT'=NPATIENT!(RECOUNT>15) S REHLDPPL=$S('$G(REHLDPPL):$P(^PS(52.5,EEEE,0),"^")_",",1:REHLDPPL_$P(^PS(52.5,EEEE,0),"^")_","),RECOUNT=RECOUNT+1,OPATIENT=$P(^PS(52.5,EEEE,0),"^",3)
...S PPL=REHLDPPL,RECOUNT=0,PSOSUREP=1,PDUZ=DUZ,ZTIO=PSOREDEV K REHLDPPL D D:$G(PPL) DQ^PSOLBL K PPL,RXRP,RXPR,RXFL
....S REPCOUNT=0 F FFF=1:1:$L(PPL) S FFFF=$E(PPL,FFF) I FFFF="," S REPCOUNT=REPCOUNT+1
....;PSO*7.0*627: Add RXRP(HHHH) for reprint flag
....; The REPRINT (#8) field does not appear to be reliable,
....; so using the "PRINTED (#2)" field instead.
....F GGGG=1:1:REPCOUNT S HHHH=$P(PPL,",",GGGG) S MMMM=$O(^PS(52.5,"B",HHHH,0)),NNNN=+$P($G(^PS(52.5,+MMMM,0)),"^",5) S:NNNN RXPR(HHHH)=$P($G(^(0)),"^",5) S RXFL(HHHH)=$P($G(^PS(52.5,+MMMM,0)),"^",13),RXRP(HHHH)=$G(^PS(52.5,+MMMM,"P"))
I $G(REHLDPPL) S PPL=REHLDPPL,PSOSUREP=1,PDUZ=DUZ,ZTIO=PSOREDEV D D:$G(PPL) DQ^PSOLBL K RXFL
.S REPCOUNT=0 F FFF=1:1:$L(PPL) S FFFF=$E(PPL,FFF) I FFFF="," S REPCOUNT=REPCOUNT+1
.;PSO*7.0*627: add RXRP(HHHH) for reprint flag
.F GGGG=1:1:REPCOUNT S HHHH=$P(PPL,",",GGGG) S MMMM=$O(^PS(52.5,"B",HHHH,0)),NNNN=+$P($G(^PS(52.5,+MMMM,0)),"^",5) S:NNNN RXPR(HHHH)=$P($G(^(0)),"^",5) S RXFL(HHHH)=$P($G(^PS(52.5,+MMMM,0)),"^",13),RXRP(HHHH)=$G(^PS(52.5,+MMMM,"P"))
END K ^UTILITY($J,"PSOREPT"),AAAA,BBBB,CCCC,DDDD,EEEE,FFF,FFFF,GGGG,HHHH,MMMM,NNNN,NPATIENT,OPATIENT,PATIFLAG,PPL,HLDDEAD,RECOUNT,REHLDPPL,REPCOUNT,RXPR,RXRP,RXFL D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
AREC ;
N RFLNUM
S PSOREEPF=0 S PSOREEP=$O(^PS(52.5,"B",RX,0)) I $G(PSOREEP),$P($G(^PS(52.5,PSOREEP,0)),"^",12) S PSOREEPF=1
I $G(PSOREEP) S RFLNUM=$P($G(^PS(52.5,PSOREEP,0)),"^",13) I RFLNUM>5 S RFLNUM=RFLNUM+1
D NOW^%DTC S DTTM=%,COM="Suspense "_$S($G(PSOREEPF):"(Reprint) ",1:"")_"Label Reprinted"_$S($G(RXP):" (Partial)",1:"")
S CNT=0 F JJ=0:0 S JJ=$O(^PSRX(RX,"A",JJ)) Q:'JJ S CNT=JJ
S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(RX,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
S CNT=CNT+1,^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT S ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_PDUZ_"^"_$S($G(RXP):6,$G(RFLNUM)'="":$G(RFLNUM),1:RFCNT)_"^"_COM
K PSOREEP,PSOREEPF Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSUSRP 3037 printed Sep 23, 2025@20:12:03 Page 2
PSOSUSRP ;BHAM ISC/RTR-Reprint label driver routine ;SEP 30, 2020@13:11
+1 ;;7.0;OUTPATIENT PHARMACY;**354,627**;DEC 1997;Build 2
+2 ;
BEG ;
+1 if '$DATA(^UTILITY($JOB,"PSOREPT"))
GOTO END
+2 SET (PATIFLAG,RECOUNT)=0
+3 NEW PSOREDEV,RXRP
SET PSOREDEV=$GET(ZTIO)
+4 FOR AAAA=0:0
SET AAAA=$ORDER(^UTILITY($JOB,"PSOREPT",AAAA))
if 'AAAA
QUIT
FOR BBBB=0:0
SET BBBB=$ORDER(^UTILITY($JOB,"PSOREPT",AAAA,BBBB))
if 'BBBB
QUIT
FOR CCCC=0:0
SET CCCC=$ORDER(^UTILITY($JOB,"PSOREPT",AAAA,BBBB,CCCC))
if 'CCCC
QUIT
Begin DoDot:1
+5 FOR DDDD=0:0
SET DDDD=$ORDER(^PS(52.5,"AS",AAAA,BBBB,CCCC,DDDD))
if 'DDDD
QUIT
FOR EEEE=0:0
SET EEEE=$ORDER(^PS(52.5,"AS",AAAA,BBBB,CCCC,DDDD,EEEE))
if 'EEEE
QUIT
if $DATA(^PS(52.5,EEEE,0))&($PIECE($GET(^(0)),"^"))&($PIECE($GET(^(0)),"^",3))
Begin DoDot:2
+6 SET DFN=$PIECE(^PS(52.5,EEEE,0),"^",3)
DO DEM^VADPT
SET HLDDEAD=VADM(6)
KILL VADM,VA("PID"),VA("BID"),DFN
IF HLDDEAD'=""
SET DA=EEEE
SET DIK="^PS(52.5,"
DO ^DIK
QUIT
+7 IF 'PATIFLAG
SET OPATIENT=$PIECE(^PS(52.5,EEEE,0),"^",3)
SET PATIFLAG=1
+8 SET NPATIENT=$PIECE(^PS(52.5,EEEE,0),"^",3)
if OPATIENT'=NPATIENT!(RECOUNT>15)
Begin DoDot:3
+9 SET PPL=REHLDPPL
SET RECOUNT=0
SET PSOSUREP=1
SET PDUZ=DUZ
SET ZTIO=PSOREDEV
KILL REHLDPPL
Begin DoDot:4
+10 SET REPCOUNT=0
FOR FFF=1:1:$LENGTH(PPL)
SET FFFF=$EXTRACT(PPL,FFF)
IF FFFF=","
SET REPCOUNT=REPCOUNT+1
+11 ;PSO*7.0*627: Add RXRP(HHHH) for reprint flag
+12 ; The REPRINT (#8) field does not appear to be reliable,
+13 ; so using the "PRINTED (#2)" field instead.
+14 FOR GGGG=1:1:REPCOUNT
SET HHHH=$PIECE(PPL,",",GGGG)
SET MMMM=$ORDER(^PS(52.5,"B",HHHH,0))
SET NNNN=+$PIECE($GET(^PS(52.5,+MMMM,0)),"^",5)
if NNNN
SET RXPR(HHHH)=$PIECE($GET(^(0)),"^",5)
SET RXFL(HHHH)=$PIECE($GET(^PS(52.5,+MMMM,0)),"^",13)
SET RXRP(HHHH)=$GET(^PS(52.5,+MMMM,"P"))
End DoDot:4
if $GET(PPL)
DO DQ^PSOLBL
KILL PPL,RXRP,RXPR,RXFL
End DoDot:3
SET REHLDPPL=$SELECT('$GET(REHLDPPL):$PIECE(^PS(52.5,EEEE,0),"^")_",",1:REHLDPPL_$PIECE(^PS(52.5,EEEE,0),"^")_",")
SET RECOUNT=RECOUNT+1
SET OPATIENT=$PIECE(^PS(52.5,EEEE,0),"^",3)
End DoDot:2
End DoDot:1
+15 IF $GET(REHLDPPL)
SET PPL=REHLDPPL
SET PSOSUREP=1
SET PDUZ=DUZ
SET ZTIO=PSOREDEV
Begin DoDot:1
+16 SET REPCOUNT=0
FOR FFF=1:1:$LENGTH(PPL)
SET FFFF=$EXTRACT(PPL,FFF)
IF FFFF=","
SET REPCOUNT=REPCOUNT+1
+17 ;PSO*7.0*627: add RXRP(HHHH) for reprint flag
+18 FOR GGGG=1:1:REPCOUNT
SET HHHH=$PIECE(PPL,",",GGGG)
SET MMMM=$ORDER(^PS(52.5,"B",HHHH,0))
SET NNNN=+$PIECE($GET(^PS(52.5,+MMMM,0)),"^",5)
if NNNN
SET RXPR(HHHH)=$PIECE($GET(^(0)),"^",5)
SET RXFL(HHHH)=$PIECE($GET(^PS(52.5,+MMMM,0)),"^",13)
SET RXRP(HHHH)=$GET(^PS(52.5,+MMMM,"P"))
End DoDot:1
if $GET(PPL)
DO DQ^PSOLBL
KILL RXFL
END KILL ^UTILITY($JOB,"PSOREPT"),AAAA,BBBB,CCCC,DDDD,EEEE,FFF,FFFF,GGGG,HHHH,MMMM,NNNN,NPATIENT,OPATIENT,PATIFLAG,PPL,HLDDEAD,RECOUNT,REHLDPPL,REPCOUNT,RXPR,RXRP,RXFL
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
AREC ;
+1 NEW RFLNUM
+2 SET PSOREEPF=0
SET PSOREEP=$ORDER(^PS(52.5,"B",RX,0))
IF $GET(PSOREEP)
IF $PIECE($GET(^PS(52.5,PSOREEP,0)),"^",12)
SET PSOREEPF=1
+3 IF $GET(PSOREEP)
SET RFLNUM=$PIECE($GET(^PS(52.5,PSOREEP,0)),"^",13)
IF RFLNUM>5
SET RFLNUM=RFLNUM+1
+4 DO NOW^%DTC
SET DTTM=%
SET COM="Suspense "_$SELECT($GET(PSOREEPF):"(Reprint) ",1:"")_"Label Reprinted"_$SELECT($GET(RXP):" (Partial)",1:"")
+5 SET CNT=0
FOR JJ=0:0
SET JJ=$ORDER(^PSRX(RX,"A",JJ))
if 'JJ
QUIT
SET CNT=JJ
+6 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(RX,1,RF))
if 'RF
QUIT
SET RFCNT=RF
if RF>5
SET RFCNT=RF+1
+7 SET CNT=CNT+1
SET ^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
SET ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_PDUZ_"^"_$SELECT($GET(RXP):6,$GET(RFLNUM)'="":$GET(RFLNUM),1:RFCNT)_"^"_COM
+8 KILL PSOREEP,PSOREEPF
QUIT
