- 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 Feb 19, 2025@00:02:02 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