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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXSRP 5917 printed Sep 23, 2025@19:21:13 Page 2
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
