PSOSUSRP ;BHAM ISC/RTR-Reprint label driver routine ;12-Feb-2009 13:23;SM
;;7.0;OUTPATIENT PHARMACY;**1008**;DEC 1997
;Modified - IHS/MSC/PLS - 02/12/09 - Calls to DQ^PSOLBL changed to DQ^APSPLBL
;
BEG ;
G:'$D(^UTILITY($J,"PSOREPT")) END
S (PATIFLAG,RECOUNT)=0
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)
...;IHS/MSC/PLS - 02/12/09
...;S PPL=REHLDPPL,RECOUNT=0,PSOSUREP=1,PDUZ=DUZ K REHLDPPL D D:$G(PPL) DQ^PSOLBL K PPL,RXRP,RXPR,RXFL
...S PPL=REHLDPPL,RECOUNT=0,PSOSUREP=1,PDUZ=DUZ K REHLDPPL D D:$G(PPL) DQ^APSPLBL 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
....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)
;IHS/MSC/PLS - 02/12/09
;I $G(REHLDPPL) S PPL=REHLDPPL,PSOSUREP=1,PDUZ=DUZ D D:$G(PPL) DQ^PSOLBL K RXFL
I $G(REHLDPPL) S PPL=REHLDPPL,PSOSUREP=1,PDUZ=DUZ D D:$G(PPL) DQ^APSPLBL K RXFL
.S REPCOUNT=0 F FFF=1:1:$L(PPL) S FFFF=$E(PPL,FFF) I FFFF="," S REPCOUNT=REPCOUNT+1
.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)
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
PSOSUSRP ;BHAM ISC/RTR-Reprint label driver routine ;12-Feb-2009 13:23;SM
+1 ;;7.0;OUTPATIENT PHARMACY;**1008**;DEC 1997
+2 ;Modified - IHS/MSC/PLS - 02/12/09 - Calls to DQ^PSOLBL changed to DQ^APSPLBL
+3 ;
BEG ;
+1 IF '$DATA(^UTILITY($JOB,"PSOREPT"))
GOTO END
+2 SET (PATIFLAG,RECOUNT)=0
+3 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
+4 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
+5 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
+6 IF 'PATIFLAG
SET OPATIENT=$PIECE(^PS(52.5,EEEE,0),"^",3)
SET PATIFLAG=1
+7 SET NPATIENT=$PIECE(^PS(52.5,EEEE,0),"^",3)
IF OPATIENT'=NPATIENT!(RECOUNT>15)
Begin DoDot:3
+8 ;IHS/MSC/PLS - 02/12/09
+9 ;S PPL=REHLDPPL,RECOUNT=0,PSOSUREP=1,PDUZ=DUZ K REHLDPPL D D:$G(PPL) DQ^PSOLBL K PPL,RXRP,RXPR,RXFL
+10 SET PPL=REHLDPPL
SET RECOUNT=0
SET PSOSUREP=1
SET PDUZ=DUZ
KILL REHLDPPL
Begin DoDot:4
+11 SET REPCOUNT=0
FOR FFF=1:1:$LENGTH(PPL)
SET FFFF=$EXTRACT(PPL,FFF)
IF FFFF=","
SET REPCOUNT=REPCOUNT+1
+12 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)
End DoDot:4
IF $GET(PPL)
DO DQ^APSPLBL
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
+13 ;IHS/MSC/PLS - 02/12/09
+14 ;I $G(REHLDPPL) S PPL=REHLDPPL,PSOSUREP=1,PDUZ=DUZ D D:$G(PPL) DQ^PSOLBL K RXFL
+15 IF $GET(REHLDPPL)
SET PPL=REHLDPPL
SET PSOSUREP=1
SET PDUZ=DUZ
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 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)
End DoDot:1
IF $GET(PPL)
DO DQ^APSPLBL
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
