- PSXSRP ;BIR/WPB - Reprint Label Driver Routine [ 01/30/98 2:19 PM ]
- ;;2.0;CMOP;**3**;11 Apr 97
- BEG ;
- G:'$D(^UTILITY($J,"PSXREPT")) END
- S (PATIFLAG,RECOUNT)=0
- F AAAA=0:0 S AAAA=$O(^UTILITY($J,"PSXREPT",AAAA)) Q:'AAAA F BBBB=0:0 S BBBB=$O(^UTILITY($J,"PSXREPT",AAAA,BBBB)) Q:'BBBB F CCCC=0:0 S CCCC=$O(^UTILITY($J,"PSXREPT",AAAA,BBBB,CCCC)) Q:'CCCC D
- .F DDDD=0:0 S DDDD=$O(^PS(52.5,"APR",AAAA,BBBB,CCCC,DDDD)) Q:'DDDD F EEEE=0:0 S EEEE=$O(^PS(52.5,"APR",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,PSXREP=1,PDUZ=DUZ K REHLDPPL D D:$G(PPL) DQ^PSOLBL K PPL,RXRP,RXPR
- ....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)
- I $G(REHLDPPL) S PPL=REHLDPPL,PSXREP=1,PDUZ=DUZ D D:$G(PPL) DQ^PSOLBL
- .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)
- Q
- AREC ;
- ;S PSXREEPF=0 S PSXREEP=$O(^PS(52.5,"B",RX,0)) I $G(PSXREEP),$P($G(^PS(52.5,PSXREEP,0)),"^",12) S PSXREEPF=1
- D NOW^%DTC S DTTM=%,COM="CMOP Suspense Label (Reprint)"
- 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
- LOCK L +^PSRX(RX):DTIME G:'$T LOCK S ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_PDUZ_"^"_$S($G(RXP):6,1:RFCNT)_"^"_COM L -^PSRX(RX)
- K PSXREEP,PSXREEPF Q
- APR ;D:X="P"&($P($G(^PS(52.5,DA,0)),"^",6))&($P($G(^(0)),"^",8))&($P($G(^(0)),"^",9))&($P($G(^(0)),"^",11))&($P($G(^PS(52.5,DA,"P")),"^"))
- D:X="P"&($P($G(^PS(52.5,DA,0)),"^",6))&($P($G(^(0)),"^",8))&($P($G(^(0)),"^",9))&($P($G(^(0)),"^",11))
- .S ^PS(52.5,"APR",$P(^PS(52.5,DA,0),"^",8),$P(^PS(52.5,DA,0),"^",9),$P(^PS(52.5,DA,0),"^",6),$P(^PS(52.5,DA,0),"^",11),DA)=""
- .K ^PS(52.5,"AS",$P(^PS(52.5,DA,0),"^",8),$P(^PS(52.5,DA,0),"^",9),$P(^PS(52.5,DA,0),"^",6),$P(^PS(52.5,DA,0),"^",11),DA)
- Q
- KAPR ;D:X='"P"&($P($G(^PS(52.5,DA,0)),"^",6))&($P($G(^(0)),"^",8))&($P($G(^(0)),"^",9))&($P($G(^(0)),"^",11))&($P($G(^PS(52.5,DA,"P")),"^"))
- ;.;K ^PS(52.5,"APR",$P(^PS(52.5,DA,0),"^",8),$P(^PS(52.5,DA,0),"^",9),$P(^PS(52.5,DA,0),"^",6),$P(^PS(52.5,DA,0),"^",11),DA)
- K:X'="P"!(X="Q") ^PS(52.5,"APR",$P(^PS(52.5,DA,0),"^",8),$P(^PS(52.5,DA,0),"^",9),$P(^PS(52.5,DA,0),"^",6),$P(^PS(52.5,DA,0),"^",11),DA)
- Q
- QUE W ! K %DT D NOW^%DTC S %DT="REAX",%DT(0)=%,%DT("B")="NOW",%DT("A")="QUEUE LABELS TO REPRINT AT WHAT TIME: " D ^%DT K %DT,%DT("A"),%DT("B"),%DT(0) I $D(DTOUT)!(Y<0) W !!?3,"Nothing queued to print!",! G START^PSXSRST
- S PSXREP=1,TIME=Y
- W ! S %ZIS("A")="REPRINT LABEL DEVICE: ",%ZIS("B")="",%ZIS="MQN" D ^%ZIS I POP!($E(IOST)["C") G BEG
- F J=0,1 S @("PSOBAR"_J)="" I $D(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J)) S @("PSOBAR"_J)=^("BAR"_J)
- S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19)
- S PSXDEV=ION
- S ZTRTN="BEG^PSXSRP",ZTDTH=TIME,ZTIO=PSXDEV,ZTDESC="REPRINT LABELS FROM SUSPENSE"
- F GG="PSOPAR","PSOSYS","PSOSITE","PSXREP","PSOBARS","PSOBAR0","PSOBAR1" S:$D(@GG) ZTSAVE(GG)=""
- F NNN=0:0 S NNN=$O(^TMP($J,"PSXRESPR",NNN)) Q:'NNN D
- .S PSRDATE=$O(^TMP($J,"PSXRESP",NNN,0)),PSRDUZ=$O(^TMP($J,"PSXRESP",NNN,PSRDATE,0)),PSRDIV=$O(^TMP($J,"PSXRESP",NNN,PSRDATE,PSRDUZ,0))
- .S ^UTILITY($J,"PSXREPT",PSRDATE,PSRDUZ,PSRDIV)=""
- S ZTSAVE("^UTILITY($J,""PSXREPT"",")="" D ^%ZTLOAD
- W !!,"REPRINTED LABELS QUEUED TO PRINT!",!
- END K ^TMP($J,"PSXRESP"),^TMP($J,"PSXRESPR"),^UTILITY($J,"PSXREPT"),%DT,%ZIS,AA,AAA,BDT,COUNT,DUOUT,DTOUT,ENDDATE,GG,INRX,JJ,LLL,MMM,NNN,POP,PSIDATE,PSXDT,XDUZ,PSXDEV,TIME,PSXREP,PSXU
- K %,AAAA,BBBB,CCCC,CNT,COM,DDDD,DTTM,EEEE,FFF,FFFF,GGGG,HHHH,HLDDEAD,J,MMMM,NNNN,NPATIENT,OPATIENT,PATIFLAG,PDUZ,RECOUNT,REPCOUNT,RF,RFCNT,RX,RXP,X,Y
- K PSRDATE,PSRDIV,PSRDUZ,RECNT,REDT,REDUZ,RR,SS,XXX,ZZ,ZZZ,ZZZ D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
- HELP ;help message, allows the user to return to the main menu or exit
- ;the routine
- W @IOF
- W !!,"1 - Reset CMOP Printed Batches for Transmission resets the CMOP printed"
- W !,"Rx's for transmission. NO LABELS are REPRINTED using this option. The",!,"Rx's from the CMOP Printed Batch selected will remain in the Rx Suspense file",!,"with a CMOP Status of 'Queued for Transmission."
- W !!,"2 - This option allows you to reprint CMOP labels that were printed from",!,"Suspense. Each time the Print from Suspense File option is run, those labels are"
- W !,"grouped in a batch. This option shows you all CMOP batches printed for the",!,"date range entered, and any number of batches may be selected to reprint."
- W !,"Only those labels that printed with the original batch will reprint, and",!,"they will reprint in the same order they were originally printed."
- W !!,"3 - This option allows you to reprint labels that were printed from suspense.",!,"Each time the Print from Suspense File option is run, those labels are"
- W !,"grouped in a batch. This option shows you all batches printed for the",!,"date range entered, and any number of batches may be selected to reprint."
- W !,"Only those labels that printed with the original batch will reprint, and",!,"they will reprint in the same order they were originally printed."
- Q
- PSXSRP ;BIR/WPB - Reprint Label Driver Routine [ 01/30/98 2:19 PM ]
- +1 ;;2.0;CMOP;**3**;11 Apr 97
- BEG ;
- +1 IF '$DATA(^UTILITY($JOB,"PSXREPT"))
- GOTO END
- +2 SET (PATIFLAG,RECOUNT)=0
- +3 FOR AAAA=0:0
- SET AAAA=$ORDER(^UTILITY($JOB,"PSXREPT",AAAA))
- IF 'AAAA
- QUIT
- FOR BBBB=0:0
- SET BBBB=$ORDER(^UTILITY($JOB,"PSXREPT",AAAA,BBBB))
- IF 'BBBB
- QUIT
- FOR CCCC=0:0
- SET CCCC=$ORDER(^UTILITY($JOB,"PSXREPT",AAAA,BBBB,CCCC))
- IF 'CCCC
- QUIT
- Begin DoDot:1
- +4 FOR DDDD=0:0
- SET DDDD=$ORDER(^PS(52.5,"APR",AAAA,BBBB,CCCC,DDDD))
- IF 'DDDD
- QUIT
- FOR EEEE=0:0
- SET EEEE=$ORDER(^PS(52.5,"APR",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 SET PPL=REHLDPPL
- SET RECOUNT=0
- SET PSXREP=1
- SET PDUZ=DUZ
- KILL REHLDPPL
- Begin DoDot:4
- +9 SET REPCOUNT=0
- FOR FFF=1:1:$LENGTH(PPL)
- SET FFFF=$EXTRACT(PPL,FFF)
- IF FFFF=","
- SET REPCOUNT=REPCOUNT+1
- +10 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)
- End DoDot:4
- IF $GET(PPL)
- DO DQ^PSOLBL
- KILL PPL,RXRP,RXPR
- 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
- +11 IF $GET(REHLDPPL)
- SET PPL=REHLDPPL
- SET PSXREP=1
- SET PDUZ=DUZ
- Begin DoDot:1
- +12 SET REPCOUNT=0
- FOR FFF=1:1:$LENGTH(PPL)
- SET FFFF=$EXTRACT(PPL,FFF)
- IF FFFF=","
- SET REPCOUNT=REPCOUNT+1
- +13 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)
- End DoDot:1
- IF $GET(PPL)
- DO DQ^PSOLBL
- +14 QUIT
- AREC ;
- +1 ;S PSXREEPF=0 S PSXREEP=$O(^PS(52.5,"B",RX,0)) I $G(PSXREEP),$P($G(^PS(52.5,PSXREEP,0)),"^",12) S PSXREEPF=1
- +2 DO NOW^%DTC
- SET DTTM=%
- SET COM="CMOP Suspense Label (Reprint)"
- +3 SET CNT=0
- FOR JJ=0:0
- SET JJ=$ORDER(^PSRX(RX,"A",JJ))
- IF 'JJ
- QUIT
- SET CNT=JJ
- +4 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
- +5 SET CNT=CNT+1
- SET ^PSRX(RX,"A",0)="^52.3DA^"_CNT_"^"_CNT
- LOCK LOCK +^PSRX(RX):DTIME
- IF '$TEST
- GOTO LOCK
- SET ^PSRX(RX,"A",CNT,0)=DTTM_"^S^"_PDUZ_"^"_$SELECT($GET(RXP):6,1:RFCNT)_"^"_COM
- LOCK -^PSRX(RX)
- +1 KILL PSXREEP,PSXREEPF
- QUIT
- APR ;D:X="P"&($P($G(^PS(52.5,DA,0)),"^",6))&($P($G(^(0)),"^",8))&($P($G(^(0)),"^",9))&($P($G(^(0)),"^",11))&($P($G(^PS(52.5,DA,"P")),"^"))
- +1 IF X="P"&($PIECE($GET(^PS(52.5,DA,0)),"^",6))&($PIECE($GET(^(0)),"^",8))&($PIECE($GET(^(0)),"^",9))&($PIECE($GET(^(0)),"^",11))
- Begin DoDot:1
- +2 SET ^PS(52.5,"APR",$PIECE(^PS(52.5,DA,0),"^",8),$PIECE(^PS(52.5,DA,0),"^",9),$PIECE(^PS(52.5,DA,0),"^",6),$PIECE(^PS(52.5,DA,0),"^",11),DA)=""
- +3 KILL ^PS(52.5,"AS",$PIECE(^PS(52.5,DA,0),"^",8),$PIECE(^PS(52.5,DA,0),"^",9),$PIECE(^PS(52.5,DA,0),"^",6),$PIECE(^PS(52.5,DA,0),"^",11),DA)
- End DoDot:1
- +4 QUIT
- KAPR ;D:X='"P"&($P($G(^PS(52.5,DA,0)),"^",6))&($P($G(^(0)),"^",8))&($P($G(^(0)),"^",9))&($P($G(^(0)),"^",11))&($P($G(^PS(52.5,DA,"P")),"^"))
- +1 ;.;K ^PS(52.5,"APR",$P(^PS(52.5,DA,0),"^",8),$P(^PS(52.5,DA,0),"^",9),$P(^PS(52.5,DA,0),"^",6),$P(^PS(52.5,DA,0),"^",11),DA)
- +2 IF X'="P"!(X="Q")
- KILL ^PS(52.5,"APR",$PIECE(^PS(52.5,DA,0),"^",8),$PIECE(^PS(52.5,DA,0),"^",9),$PIECE(^PS(52.5,DA,0),"^",6),$PIECE(^PS(52.5,DA,0),"^",11),DA)
- +3 QUIT
- QUE WRITE !
- KILL %DT
- DO NOW^%DTC
- SET %DT="REAX"
- SET %DT(0)=%
- SET %DT("B")="NOW"
- SET %DT("A")="QUEUE LABELS TO REPRINT AT WHAT TIME: "
- DO ^%DT
- KILL %DT,%DT("A"),%DT("B"),%DT(0)
- IF $DATA(DTOUT)!(Y<0)
- WRITE !!?3,"Nothing queued to print!",!
- GOTO START^PSXSRST
- +1 SET PSXREP=1
- SET TIME=Y
- +2 WRITE !
- SET %ZIS("A")="REPRINT LABEL DEVICE: "
- SET %ZIS("B")=""
- SET %ZIS="MQN"
- DO ^%ZIS
- IF POP!($EXTRACT(IOST)["C")
- GOTO BEG
- +3 FOR J=0,1
- SET @("PSOBAR"_J)=""
- IF $DATA(^%ZIS(2,^%ZIS(1,IOS,"SUBTYPE"),"BAR"_J))
- SET @("PSOBAR"_J)=^("BAR"_J)
- +4 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",19)
- +5 SET PSXDEV=ION
- +6 SET ZTRTN="BEG^PSXSRP"
- SET ZTDTH=TIME
- SET ZTIO=PSXDEV
- SET ZTDESC="REPRINT LABELS FROM SUSPENSE"
- +7 FOR GG="PSOPAR","PSOSYS","PSOSITE","PSXREP","PSOBARS","PSOBAR0","PSOBAR1"
- IF $DATA(@GG)
- SET ZTSAVE(GG)=""
- +8 FOR NNN=0:0
- SET NNN=$ORDER(^TMP($JOB,"PSXRESPR",NNN))
- IF 'NNN
- QUIT
- Begin DoDot:1
- +9 SET PSRDATE=$ORDER(^TMP($JOB,"PSXRESP",NNN,0))
- SET PSRDUZ=$ORDER(^TMP($JOB,"PSXRESP",NNN,PSRDATE,0))
- SET PSRDIV=$ORDER(^TMP($JOB,"PSXRESP",NNN,PSRDATE,PSRDUZ,0))
- +10 SET ^UTILITY($JOB,"PSXREPT",PSRDATE,PSRDUZ,PSRDIV)=""
- End DoDot:1
- +11 SET ZTSAVE("^UTILITY($J,""PSXREPT"",")=""
- DO ^%ZTLOAD
- +12 WRITE !!,"REPRINTED LABELS QUEUED TO PRINT!",!
- END KILL ^TMP($JOB,"PSXRESP"),^TMP($JOB,"PSXRESPR"),^UTILITY($JOB,"PSXREPT"),%DT,%ZIS,AA,AAA,BDT,COUNT,DUOUT,DTOUT,ENDDATE,GG,INRX,JJ,LLL,MMM,NNN,POP,PSIDATE,PSXDT,XDUZ,PSXDEV,TIME,PSXREP,PSXU
- +1 KILL %,AAAA,BBBB,CCCC,CNT,COM,DDDD,DTTM,EEEE,FFF,FFFF,GGGG,HHHH,HLDDEAD,J,MMMM,NNNN,NPATIENT,OPATIENT,PATIFLAG,PDUZ,RECOUNT,REPCOUNT,RF,RFCNT,RX,RXP,X,Y
- +2 KILL PSRDATE,PSRDIV,PSRDUZ,RECNT,REDT,REDUZ,RR,SS,XXX,ZZ,ZZZ,ZZZ
- DO ^%ZISC
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- HELP ;help message, allows the user to return to the main menu or exit
- +1 ;the routine
- +2 WRITE @IOF
- +3 WRITE !!,"1 - Reset CMOP Printed Batches for Transmission resets the CMOP printed"
- +4 WRITE !,"Rx's for transmission. NO LABELS are REPRINTED using this option. The",!,"Rx's from the CMOP Printed Batch selected will remain in the Rx Suspense file",!,"with a CMOP Status of 'Queued for Transmission."
- +5 WRITE !!,"2 - This option allows you to reprint CMOP labels that were printed from",!,"Suspense. Each time the Print from Suspense File option is run, those labels are"
- +6 WRITE !,"grouped in a batch. This option shows you all CMOP batches printed for the",!,"date range entered, and any number of batches may be selected to reprint."
- +7 WRITE !,"Only those labels that printed with the original batch will reprint, and",!,"they will reprint in the same order they were originally printed."
- +8 WRITE !!,"3 - This option allows you to reprint labels that were printed from suspense.",!,"Each time the Print from Suspense File option is run, those labels are"
- +9 WRITE !,"grouped in a batch. This option shows you all batches printed for the",!,"date range entered, and any number of batches may be selected to reprint."
- +10 WRITE !,"Only those labels that printed with the original batch will reprint, and",!,"they will reprint in the same order they were originally printed."
- +11 QUIT
