- 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
