PRCAG ;WASH-ISC@ALTOONA,PA/CMS-Reprint Statement/Letter Option Entries ;8/23/93 2:42 PM
V ;;4.5;Accounts Receivable;**149,165,198**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
REP ;ENTRY FROM REPRINT PAT STATEMENT
NEW BEG,END,DAT,DATE,DEB,DIC,HDAT,IOP,SITE,TYP,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT
W !!
ADT S %DT="AEXP",%DT(0)="-NOW",%DT("A")="Enter a Date to Reprint: " D ^%DT I Y<1 G REPQ
S Y=$P(Y,".")
I $P($O(^RC(341,"C",Y)),".")'=Y W !!,*7,"No notifications sent on that date",! G ADT
S DAT=9999999-Y
W !!,"Press return at the 'Patient:' prompts to reprint all patient statements",!,"for the date selected or select a start and/or end point."
W !,"NOTE: The range is in print order not alphabetic!",!
N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
S DIC="^RCD(340,",DIC(0)="AEMNQ",DIC("A")="Start from Patient: ",DIC("S")="I $P(^(0),U,1)[""DPT""" D ^DIC I ($D(DTOUT))!(X["^") G REPQ
S BEG=0,Y=+Y
I Y>0 S BEG=-1,DEB=+Y,TYP=+$O(^RC(341.1,"AC",2,0)) F DATE=DAT-.0001:0 S DATE=$O(^RC(341,"AD",DEB,TYP,DATE)) Q:$P(DATE,".")'=DAT S BEG=$O(^RC(341,"AD",DEB,TYP,DATE,0)) Q
I BEG=0 S BEG=$O(^RC(341,"C",+$O(^RC(341,"C",9999999-DAT)),0)) S:'BEG BEG=-1
I BEG<0 W *7,!," Sorry, Debtor Statement not found on this date!" G ADT
S DIC="^RCD(340,",DIC(0)="AEMNQ",DIC("A")="End after Patient: ",DIC("S")="I $P(^(0),U,1)[""DPT""" D ^DIC I ($D(DTOUT))!(X["^") G REPQ
S END="*",Y=+Y
I Y>0 S END=-1,DEB=+Y,TYP=+$O(^RC(341.1,"AC",2,0)) F DATE=DAT-.0001:0 S DATE=$O(^RC(341,"AD",DEB,TYP,DATE)) Q:$P(DATE,".")'=DAT S END=$O(^RC(341,"AD",DEB,TYP,DATE,0)) Q
I END<0 W *7,!," Sorry, Debtor Statement not found on this date!" G ADT
I END'="*",END<BEG W *7,!,"Ending bill is before starting bill!" G ADT
S HDAT=9999999-DAT
REPD W !! S %ZIS="QN",IOP="Q",%ZIS("B")=$P($G(^RC(342,1,0)),U,8) D ^%ZIS G:POP REPQ
I '$D(IO("Q")) W !!,*7,"YOU MUST QUEUE THIS OUTPUT",! G REPD
S ZTRTN="REP^PRCAGS",ZTDESC="Reprint AR Patient Statements",ZTSAVE("BEG")="",ZTSAVE("END")="",ZTSAVE("HDAT")="" D ^%ZTLOAD
REPQ D ^%ZISC Q
UB ;ENTRY FROM REPRINT UB BILLS
S ETY="UB" ;set event type to UB and use REB sub-routine
REB ;ENTRY FROM REPRINT FOLLOW-UP LETTERS
NEW BEG,END,DAT,DATE,DEB,DIC,IOP,SITE,TYP,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT
D SITE^PRCAGU
S:'$D(ETY) ETY="FL"
REBDT S %DT="AEXP",%DT(0)="-NOW",%DT("A")="Enter a Date to Reprint: " D ^%DT G:Y<1 REBQ
S Y=$P(Y,".")
I $P($O(^RC(341,"C",Y)),".")'=Y W !!,*7,"No notifications sent on that date",! G REBDT
S DAT=9999999-Y
W !!,"Press return at the 'Bill:' prompts to reprint all ",ETY," Letters",!,"for the date selected or select a start and/or end point."
W !,"Do not select bills that print on the Patient Statement."
W !,"NOTE: The range is in print order not alphabetic!",!
N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
S DIC="^PRCA(430,",DIC(0)="AEMNQ",DIC("A")="Start from Bill: ",DIC("S")="I "",18,25,5,24,1,2,3,4,23,22,""'[("",""_$P(^(0),U,2)_"","")" D ^DIC I ($D(DTOUT))!(X["^") G REBQ
S BEG=0,Y=+Y
I Y>0 S BEG=-1,DEB=+$P($G(^PRCA(430,Y,0)),U,9),TYP=+$O(^RC(341.1,"AC",$S(ETY="UB":9,1:10),0)) F DATE=DAT-.0001:0 S DATE=$O(^RC(341,"AD",DEB,TYP,DATE)) Q:$P(DATE,".")'=DAT D
.F DA=0:0 S DA=$O(^RC(341,"AD",DEB,TYP,DATE,DA)) Q:'DA I +$G(^RC(341,DA,5))=Y S BEG=DA,DEB=0 Q
.Q
I BEG=0 S BEG=$O(^RC(341,"C",+$O(^RC(341,"C",9999999-DAT)),0)) S:'BEG BEG=-1
I BEG<0 W *7,!," Sorry, not found!" G REBDT
S DIC("A")="End after Bill: " D ^DIC I ($D(DTOUT))!(X["^") G REBQ
S END="*",Y=+Y
I Y>0 S END=-1,DEB=+$P($G(^PRCA(430,Y,0)),U,9),TYP=+$O(^RC(341.1,"AC",$S(ETY="UB":9,1:10),0)) F DATE=DAT-.0001:0 S DATE=$O(^RC(341,"AD",DEB,TYP,DATE)) Q:$P(DATE,".")'=DAT D
.F DA=0:0 S DA=$O(^RC(341,"AD",DEB,TYP,DATE,DA)) Q:'DA I +$G(^RC(341,DA,5))=Y S END=DA,DEB=0 Q
.Q
I END<0 W *7,!," Sorry, not found!" G REBDT
I END'="*",END<BEG W *7,!,"Ending bill is before starting bill!" G REBDT
W !!
REBD I ETY="UB" S ZTIO="" G REBD1
S %ZIS("B")=$P($G(^RC(342,1,0)),U,8),%ZIS="QN",IOP="Q" D ^%ZIS G:POP REBQ
I '$D(IO("Q")) W !!,*7,"YOU MUST QUEUE THIS OUTPUT",! G REBD
REBD1 S ZTRTN="BILL^PRCAGS",ZTSAVE("BEG")="",ZTSAVE("END")="",ZTSAVE("DAT")="",ZTSAVE("SITE")="",ZTSAVE("ETY")=""
S ZTDESC=$S(ETY="UB":"AR Reprint UB Letters",1:"Reprint AR Follow-up Letters") D ^%ZTLOAD
REBQ K ETY D ^%ZISC Q
PRDT ;ENTRY FROM PRINT STATEMENT/LETTER BY DATE OPTION
D PRDT^PRCAGP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAG 4391 printed Dec 13, 2024@01:39:37 Page 2
PRCAG ;WASH-ISC@ALTOONA,PA/CMS-Reprint Statement/Letter Option Entries ;8/23/93 2:42 PM
V ;;4.5;Accounts Receivable;**149,165,198**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
REP ;ENTRY FROM REPRINT PAT STATEMENT
+1 NEW BEG,END,DAT,DATE,DEB,DIC,HDAT,IOP,SITE,TYP,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT
+2 WRITE !!
ADT SET %DT="AEXP"
SET %DT(0)="-NOW"
SET %DT("A")="Enter a Date to Reprint: "
DO ^%DT
IF Y<1
GOTO REPQ
+1 SET Y=$PIECE(Y,".")
+2 IF $PIECE($ORDER(^RC(341,"C",Y)),".")'=Y
WRITE !!,*7,"No notifications sent on that date",!
GOTO ADT
+3 SET DAT=9999999-Y
+4 WRITE !!,"Press return at the 'Patient:' prompts to reprint all patient statements",!,"for the date selected or select a start and/or end point."
+5 WRITE !,"NOTE: The range is in print order not alphabetic!",!
+6 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+7 SET DIC="^RCD(340,"
SET DIC(0)="AEMNQ"
SET DIC("A")="Start from Patient: "
SET DIC("S")="I $P(^(0),U,1)[""DPT"""
DO ^DIC
IF ($DATA(DTOUT))!(X["^")
GOTO REPQ
+8 SET BEG=0
SET Y=+Y
+9 IF Y>0
SET BEG=-1
SET DEB=+Y
SET TYP=+$ORDER(^RC(341.1,"AC",2,0))
FOR DATE=DAT-.0001:0
SET DATE=$ORDER(^RC(341,"AD",DEB,TYP,DATE))
if $PIECE(DATE,".")'=DAT
QUIT
SET BEG=$ORDER(^RC(341,"AD",DEB,TYP,DATE,0))
QUIT
+10 IF BEG=0
SET BEG=$ORDER(^RC(341,"C",+$ORDER(^RC(341,"C",9999999-DAT)),0))
if 'BEG
SET BEG=-1
+11 IF BEG<0
WRITE *7,!," Sorry, Debtor Statement not found on this date!"
GOTO ADT
+12 SET DIC="^RCD(340,"
SET DIC(0)="AEMNQ"
SET DIC("A")="End after Patient: "
SET DIC("S")="I $P(^(0),U,1)[""DPT"""
DO ^DIC
IF ($DATA(DTOUT))!(X["^")
GOTO REPQ
+13 SET END="*"
SET Y=+Y
+14 IF Y>0
SET END=-1
SET DEB=+Y
SET TYP=+$ORDER(^RC(341.1,"AC",2,0))
FOR DATE=DAT-.0001:0
SET DATE=$ORDER(^RC(341,"AD",DEB,TYP,DATE))
if $PIECE(DATE,".")'=DAT
QUIT
SET END=$ORDER(^RC(341,"AD",DEB,TYP,DATE,0))
QUIT
+15 IF END<0
WRITE *7,!," Sorry, Debtor Statement not found on this date!"
GOTO ADT
+16 IF END'="*"
IF END<BEG
WRITE *7,!,"Ending bill is before starting bill!"
GOTO ADT
+17 SET HDAT=9999999-DAT
REPD WRITE !!
SET %ZIS="QN"
SET IOP="Q"
SET %ZIS("B")=$PIECE($GET(^RC(342,1,0)),U,8)
DO ^%ZIS
if POP
GOTO REPQ
+1 IF '$DATA(IO("Q"))
WRITE !!,*7,"YOU MUST QUEUE THIS OUTPUT",!
GOTO REPD
+2 SET ZTRTN="REP^PRCAGS"
SET ZTDESC="Reprint AR Patient Statements"
SET ZTSAVE("BEG")=""
SET ZTSAVE("END")=""
SET ZTSAVE("HDAT")=""
DO ^%ZTLOAD
REPQ DO ^%ZISC
QUIT
UB ;ENTRY FROM REPRINT UB BILLS
+1 ;set event type to UB and use REB sub-routine
SET ETY="UB"
REB ;ENTRY FROM REPRINT FOLLOW-UP LETTERS
+1 NEW BEG,END,DAT,DATE,DEB,DIC,IOP,SITE,TYP,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT
+2 DO SITE^PRCAGU
+3 if '$DATA(ETY)
SET ETY="FL"
REBDT SET %DT="AEXP"
SET %DT(0)="-NOW"
SET %DT("A")="Enter a Date to Reprint: "
DO ^%DT
if Y<1
GOTO REBQ
+1 SET Y=$PIECE(Y,".")
+2 IF $PIECE($ORDER(^RC(341,"C",Y)),".")'=Y
WRITE !!,*7,"No notifications sent on that date",!
GOTO REBDT
+3 SET DAT=9999999-Y
+4 WRITE !!,"Press return at the 'Bill:' prompts to reprint all ",ETY," Letters",!,"for the date selected or select a start and/or end point."
+5 WRITE !,"Do not select bills that print on the Patient Statement."
+6 WRITE !,"NOTE: The range is in print order not alphabetic!",!
+7 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+8 SET DIC="^PRCA(430,"
SET DIC(0)="AEMNQ"
SET DIC("A")="Start from Bill: "
SET DIC("S")="I "",18,25,5,24,1,2,3,4,23,22,""'[("",""_$P(^(0),U,2)_"","")"
DO ^DIC
IF ($DATA(DTOUT))!(X["^")
GOTO REBQ
+9 SET BEG=0
SET Y=+Y
+10 IF Y>0
SET BEG=-1
SET DEB=+$PIECE($GET(^PRCA(430,Y,0)),U,9)
SET TYP=+$ORDER(^RC(341.1,"AC",$SELECT(ETY="UB":9,1:10),0))
FOR DATE=DAT-.0001:0
SET DATE=$ORDER(^RC(341,"AD",DEB,TYP,DATE))
if $PIECE(DATE,".")'=DAT
QUIT
Begin DoDot:1
+11 FOR DA=0:0
SET DA=$ORDER(^RC(341,"AD",DEB,TYP,DATE,DA))
if 'DA
QUIT
IF +$GET(^RC(341,DA,5))=Y
SET BEG=DA
SET DEB=0
QUIT
+12 QUIT
End DoDot:1
+13 IF BEG=0
SET BEG=$ORDER(^RC(341,"C",+$ORDER(^RC(341,"C",9999999-DAT)),0))
if 'BEG
SET BEG=-1
+14 IF BEG<0
WRITE *7,!," Sorry, not found!"
GOTO REBDT
+15 SET DIC("A")="End after Bill: "
DO ^DIC
IF ($DATA(DTOUT))!(X["^")
GOTO REBQ
+16 SET END="*"
SET Y=+Y
+17 IF Y>0
SET END=-1
SET DEB=+$PIECE($GET(^PRCA(430,Y,0)),U,9)
SET TYP=+$ORDER(^RC(341.1,"AC",$SELECT(ETY="UB":9,1:10),0))
FOR DATE=DAT-.0001:0
SET DATE=$ORDER(^RC(341,"AD",DEB,TYP,DATE))
if $PIECE(DATE,".")'=DAT
QUIT
Begin DoDot:1
+18 FOR DA=0:0
SET DA=$ORDER(^RC(341,"AD",DEB,TYP,DATE,DA))
if 'DA
QUIT
IF +$GET(^RC(341,DA,5))=Y
SET END=DA
SET DEB=0
QUIT
+19 QUIT
End DoDot:1
+20 IF END<0
WRITE *7,!," Sorry, not found!"
GOTO REBDT
+21 IF END'="*"
IF END<BEG
WRITE *7,!,"Ending bill is before starting bill!"
GOTO REBDT
+22 WRITE !!
REBD IF ETY="UB"
SET ZTIO=""
GOTO REBD1
+1 SET %ZIS("B")=$PIECE($GET(^RC(342,1,0)),U,8)
SET %ZIS="QN"
SET IOP="Q"
DO ^%ZIS
if POP
GOTO REBQ
+2 IF '$DATA(IO("Q"))
WRITE !!,*7,"YOU MUST QUEUE THIS OUTPUT",!
GOTO REBD
REBD1 SET ZTRTN="BILL^PRCAGS"
SET ZTSAVE("BEG")=""
SET ZTSAVE("END")=""
SET ZTSAVE("DAT")=""
SET ZTSAVE("SITE")=""
SET ZTSAVE("ETY")=""
+1 SET ZTDESC=$SELECT(ETY="UB":"AR Reprint UB Letters",1:"Reprint AR Follow-up Letters")
DO ^%ZTLOAD
REBQ KILL ETY
DO ^%ZISC
QUIT
PRDT ;ENTRY FROM PRINT STATEMENT/LETTER BY DATE OPTION
+1 DO PRDT^PRCAGP
+2 QUIT
