RCDPEAR2 ;ALB/TMK/PJH - EFT Unmatched Aging Report - FILE 344.3 ;Nov 24, 2014@18:31:57
;;4.5;Accounts Receivable;**173,269,276,284,283,293,298,318,321,326,432**;Mar 20, 1995;Build 16
;Per VA Directive 6402, this routine should not be modified.
Q
;
; PRCA*4.5*298 notes at bottom
EN1 ; option: EFT Unmatched Aging Report [RCDPE EFT AGING REPORT]
N %ZIS,DIC,DIR,DTOUT,DUOUT,POP,RCDISPTY,RCDTRNG,RCEND,RCHDR
N RCJOB1,RCLSTMGR,RCPAR,RCPAY,RCPGNUM,RCSTART,RCTMPND,RCTYPE,X,Y
; RCDISPTY = display type
; RCEND = end date
; RCLSTMGR = list manager flag
; RCTYPE = Type of payers to include M/P/T/C/A MEDICAL/PHARMACY/TRICARE/CHAMPVA/ALL
; RCDTRNG= "1^start date^end date"
; RCSTART = start date
; RCTMPND = name of the subscript for ^TMP to use
; RCPAY = A - All payers, S - Selected Payers, R - Range of Payers
;
S RCLSTMGR="" ; initial value
S RCDTRNG=$$DTRNG^RCDPEM4() G:'(RCDTRNG>0) EN1Q
S RCSTART=$P(RCDTRNG,U,2)-1,RCEND=$P(RCDTRNG,U,3)
;
; PRCA*4.5*326 - Ask to show Medical/Pharmacy Tricare or All ; PRCA*4.5*4.32 CHAMPVA
S RCTYPE=$$RTYPE^RCDPEU1("")
I RCTYPE=-1 G EN1Q
;
S RCPAY=$$PAYRNG^RCDPEU1() ; PRCA*4.5*326 - Selected or Range of Payers
I RCPAY=-1 G EN1Q ; PRCA*4.5*326 '^' or timeout
;
I RCPAY'="A" D I XX=-1 G EN1Q ; PRCA*4.5*326 - Since we don't want all payers
. S RCPAR("TYPE")=RCTYPE ; prompt for payers we do want
. S RCPAR("SELC")=RCPAY
. S RCPAR("FILE")=344.31
. S RCPAR("DICA")="Select Insurance Company NAME: "
. S XX=$$SELPAY^RCDPEU1(.RCPAR)
;
;Get display type
S RCDISPTY=$$DISPTY^RCDPEM3() G:RCDISPTY<0 EN1Q
; display device info about Excel format, set ListMan flag to prevent question
I RCDISPTY S RCLSTMGR="^" D INFO^RCDPEM6
I $D(DUOUT)!$D(DTOUT) G EN1Q
;
; if not output to Excel ask for ListMan display, exit if timeout or '^' - PRCA*4.5*298
I RCLSTMGR="" S RCLSTMGR=$$ASKLM^RCDPEARL I RCLSTMGR<0 G EN1Q
; display in ListMan format and exit on return
I RCLSTMGR D G EN1Q
.S RCTMPND=$T(+0)_"^EFT UNMATCHED AGING" K ^TMP($J,RCTMPND) ; clean any residue
.D RPTOUT
.N H,L,HDR S L=0
.S HDR("TITLE")=$$HDRNM
.F H=1:1:7 I $D(RCHDR(H)) S L=H,HDR(H)=RCHDR(H) ; take first 3 lines of report header
.I $O(RCHDR(L)) D ; any remaining header lines at top of report
..N N S N=0,H=L F S H=$O(RCHDR(H)) Q:'H S N=N+.001,^TMP($J,RCTMPND,N)=RCHDR(H)
.D LMRPT^RCDPEARL(.HDR,$NA(^TMP($J,RCTMPND))) ; generate ListMan display
;
S RCTMPND=""
; Ask device
S %ZIS="QM" D ^%ZIS G:POP EN1Q
I $D(IO("Q")) D G EN1Q
.N ZTDESC,ZTRTN,ZTSAVE,ZTSTOP
.S ZTRTN="RPTOUT^RCDPEAR2",ZTDESC="EFT AGING REPORT"
.S ZTSAVE("RC*")="",ZTSAVE("VAUTD")=""
.S ZTSAVE("^TMP(""RCDPEU1"",$J,")="" ; PRCA*4.5*326
.D ^%ZTLOAD
.W !!,$S($G(ZTSK):"Task number "_ZTSK_" has been queued.",1:"Unable to queue this task.")
.K ZTSK,IO("Q") D HOME^%ZIS
;
U IO D RPTOUT
;
EN1Q ; exit and clean up
I 'RCLSTMGR D ^%ZISC
K ^TMP("RCSELPAY",$J),^TMP("RCPAYER",$J),^TMP("RCDPEU1",$J) ; PRCA*4.5*326
Q
;
RPTOUT ; Entry point for queued job, nightly job
; RCTMPND = name of the subscript for ^TMP to use to return all lines
; If undefined or null, output is printed
; Return global if RCTMPND not null: ^TMP($J,RCTMPND,line#)=line text
N DIC,DUOUT,RC0,RC13,RC3443,RCCT,RCIEN,RCNT,RCOUT,RCPAYER,RCPAYID
N RCSTOP,RCTOT,RCZ,X,XX,YY,Z,Z0,ZZ
S RCTMPND=$G(RCTMPND)
S (RCCT,RCSTOP,RCNT,RCTOT)=0
K ^TMP($J,"RCERA_AGED"),^TMP($J,"RCERA_ADJ")
; build local payer array here
I RCTMPND'="" K ^TMP($J,RCTMPND)
; cross-ref on file #344.31 field #.08 - MATCH STATUS
S RCIEN=0 F S RCIEN=$O(^RCY(344.31,"AMATCH",0,RCIEN)) Q:'RCIEN D ;unmatched entries only
.Q:$P($G(^RCY(344.31,RCIEN,3)),U) ; EFT has been removed
.Q:$P($G(^RCY(344.31,RCIEN,0)),U,7)=0 ; payment of zero
.;
.S RC13=$P($G(^RCY(344.31,RCIEN,0)),U,13) ; date received
.; Check for payer match
.I RCPAY'="A" D Q:'XX
.. S XX=$$ISSEL^RCDPEU1(344.31,RCIEN) ; PRCA*4.5*326 Check if payer was selected
.E I RCTYPE'="A" D Q:'XX ; If all of a give type of payer selected
.. S XX=$$ISTYPE^RCDPEU1(344.31,RCIEN,RCTYPE) ; check that payer matches type
.; Check date range
.Q:(RCSTART>RC13)!(RC13>RCEND)
.; Passed all the filters - include on report
.S ^TMP($J,"RCEFT_AGED",$$FMDIFF^XLFDT(RC13,DT),RCIEN)=0,RCNT=RCNT+1
;
D:'RCLSTMGR HDRBLD ; create header
D:RCLSTMGR HDRLM ; create Listman header
;
I RCDISPTY D EXCEL Q
;
; Find total amount of EFTs
S RCZ="" F S RCZ=$O(^TMP($J,"RCEFT_AGED",RCZ)) Q:RCZ="" S RCIEN=0 F S RCIEN=$O(^TMP($J,"RCEFT_AGED",RCZ,RCIEN)) Q:'RCIEN D G:RCSTOP PRTQ
.I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPGNUM) W:RCTMPND="" !!,"***TASK STOPPED BY USER***" Q
.S RC0=$G(^RCY(344.31,RCIEN,0)),RC3443=$G(^RCY(344.3,+RC0,0))
.D DEBEFT^RCDPEARL(.RC0) ;Add minus sign for debit amounts PRCA*4.5*432
.S RCTOT=RCTOT+$P(RC0,U,7)
;
D:'RCLSTMGR HDRLST^RCDPEARL(.RCSTOP,.RCHDR) ; initial report header
;
S Z=$$SETSTR^VALM1("Totals:","",1,79)
D SL^RCDPEARL(Z,.RCCT,RCTMPND)
S Z=$$SETSTR^VALM1(" Number Aged Electronic EFT Messages Found: "_RCNT,"",1,79)
D SL^RCDPEARL(Z,.RCCT,RCTMPND)
S Z=$$SETSTR^VALM1(" Amount Aged Electronic EFT Messages Found: $"_$FN(+RCTOT,",",2),"",1,79)
D SL^RCDPEARL(Z,.RCCT,RCTMPND)
D SL^RCDPEARL($TR($J("",IOM)," ","="),.RCCT,RCTMPND)
;
S RCZ="" F S RCZ=$O(^TMP($J,"RCEFT_AGED",RCZ)) Q:RCZ="" S RCIEN=0 F S RCIEN=$O(^TMP($J,"RCEFT_AGED",RCZ,RCIEN)) Q:'RCIEN D G:RCSTOP PRTQ
.I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPGNUM) W:RCTMPND="" !!,"***TASK STOPPED BY USER***" Q
.I RCPGNUM D SL^RCDPEARL(" ",.RCCT,.RCTMPND) ; On detail list, skip line
.I 'RCLSTMGR,$Y>(IOSL-RCHDR(0)) D HDRLST^RCDPEARL(.RCSTOP,.RCHDR) Q:RCSTOP
.S RC0=$G(^RCY(344.31,RCIEN,0)),RC3443=$G(^RCY(344.3,+RC0,0))
.D DEBEFT^RCDPEARL(.RC0) ;Add minus sign for debit amounts PRCA*4.5*432
.S RCTOT=RCTOT+$P(RC0,U,7)
.S Z=$$SETSTR^VALM1($J(-RCZ,4),"",1,4)
.; PRCA*4.5*318 moved deposit date up a row to give more room for payer/payer ID
.S Z=$$SETSTR^VALM1(" "_$P(RC0,U,4),Z,5,52) ;trace#
.S Z=$$SETSTR^VALM1($$FMTE^XLFDT($P(RC0,U,12),2),Z,73,8) ; deposit date
.D SL^RCDPEARL(Z,.RCCT,RCTMPND)
.N RCPAY S RCPAY=$P(RC0,U,2) S:RCPAY="" RCPAY="NO PAYER NAME RECEIVED" ; PRCA*4.5*298
.S RCPAYID=$P(RC0,U,3) ; Payer ID ;PRCA*4.5*298
.;PRCA*4.5*318 dynamically display payer name/ID based on length
.S RCPAYER=RCPAY_"/"_RCPAYID
.I $L(RCPAYER)>76 D
. . S ZZ=$L(RCPAYER,"/"),XX=$P(RCPAYER,"/",1,ZZ-1),YY=$P(RCPAYER,"/",ZZ)
. . S XX=$E(RCPAYER,1,$L(XX)-($L(RCPAYER)-76)),RCPAYER=XX_"/"_YY
.S Z=$$SETSTR^VALM1(RCPAYER,"",5,76) ; PRCA*4.5*298 (payer/payer ID)
.;S Z=$$SETSTR^VALM1(" "_$$FMTE^XLFDT($P(RC0,U,12),2),Z,70,10) ; deposit date
.;end of PRCA*4.5*318 display change
.D SL^RCDPEARL(Z,.RCCT,RCTMPND)
.S Z=$$SETSTR^VALM1($J("",6)_$S($P(RC0,U,13):$$FMTE^XLFDT($P(RC0,U,13),2),1:""),"",1,17)
.S Z=$$SETSTR^VALM1(" "_$J($P(RC0,U,7),15,2),Z,18,17)
.; PRCA*4.5*283 - change length from 8 to 11 to allow for 9 digit DEP #'s
.; PRCA*4.5*326 - add EFT identifier
.S Z=$$SETSTR^VALM1(" "_$P(RC3443,U,6)_"/"_$$GET1^DIQ(344.31,RCIEN_",",.01,"E"),Z,35,17)
.S Z=$$SETSTR^VALM1(" "_$S($P(RC3443,U,12):"",1:"NOT ")_"Posted to 8NZZ"_$S($P(RC3443,U,12):" "_$$FMTE^XLFDT($P(RC3443,U,11),2),1:""),Z,52,36)
.D SL^RCDPEARL(Z,.RCCT,RCTMPND)
.K RCOUT
.D GETS^DIQ(344.31,RCIEN_",",2,"E","RCOUT")
.Q:'$O(RCOUT(344.31,RCIEN_",",2,0))
.D SL^RCDPEARL($J("",8)_"--EXCEPTION NOTES--",.RCCT,RCTMPND)
.S Z=0 F S Z=$O(RCOUT(344.31,RCIEN_",",2,Z)) Q:'Z D Q:RCSTOP
..I 'RCLSTMGR,$Y>(IOSL-RCHDR(0)) D HDRLST^RCDPEARL(.RCSTOP,.RCHDR) Q:RCSTOP
..D SL^RCDPEARL($J("",8)_" "_RCOUT(344.31,RCIEN_",",2,Z),.RCCT,RCTMPND)
;
;
; PRCA*4.5*298, put end-of-report into SL^RCDPEARL
D SL^RCDPEARL(" ",.RCCT,RCTMPND) ; skip a line
D SL^RCDPEARL($$ENDORPRT^RCDPEARL,.RCCT,RCTMPND)
;
PRTQ ;
; PRCA*4.5*298, added ListMan check
I '$D(ZTQUEUED),'RCLSTMGR,'RCSTOP D ASK^RCDPEARL(.RCSTOP)
I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ZTQUEUED) D ^%ZISC
K ^TMP($J,"RCEFT_AGED"),ZTQUEUED
K ^TMP("RCDPEU1",$J) ; PRCA*4.5*326
Q
;
; extrinsic variable, text for header PRCA*4.5*298
HDRNM() Q "EFT UNMATCHED AGING REPORT"
;
HDRBLD ; create the report header
; returns RCHDR, RCPGNUM, RCSTOP
; RCHDR(0) = header text line count
; RCHDR("XECUTE") = M code for page number
; RCHDR("RUNDATE") = date/time report generated, external format
; RCPGNUM - page counter
; RCSTOP - flag to exit
;INPUT:
; RCDTRNG - date range filter value to be printed as part of the header
; RCPAY - Payer filter value(s)
; RCLSTMGR
;
K RCHDR S RCHDR("RUNDATE")=$$NOW^RCDPEARL,RCPGNUM=0,RCSTOP=0
;
I RCDISPTY D Q ; Excel format, xecute code is QUIT, null page number
.S RCHDR(0)=1,RCHDR("XECUTE")="Q",RCPGNUM=""
.S RCHDR(1)="Aged Days^Trace #^Deposit From/ID^File Date^Deposit Amount^Dep#/EFT#^Deposit Post Status^Deposit Date" ; PRCA*4.3*326
;
N START,END,MSG,DATE,Y,DIV,HCNT
S START=$$FMTE^XLFDT($P(RCDTRNG,U,2),2),END=$$FMTE^XLFDT($P(RCDTRNG,U,3),2)
;
S Y=$$HDRNM,HCNT=1,RCHDR(HCNT)=$J("",80-$L(Y)\2)_Y ; line 1 will be replaced by XECUTE code below
S RCHDR("XECUTE")="N Y S RCPGNUM=RCPGNUM+1,Y=$$HDRNM^"_$T(+0)_"_$S(RCLSTMGR:"""",1:$J(""Page: ""_RCPGNUM,12)),RCHDR(1)=$J("" "",80-$L(Y)\2)_Y"
S Y="RUN DATE: "_RCHDR("RUNDATE"),HCNT=HCNT+1,RCHDR(HCNT)=$J("",80-$L(Y)\2)_Y ; line 1 will be replaced by XECUTE code below
;
; Payer(s) - PRCA*4.5*326 Add MPT filter
S Y="PAYERS: "_$S(RCPAY="R":"RANGE",RCPAY="S":"SELECTED",1:"ALL")
S Y=$E(Y_$J("",80),1,38)_"MEDICAL/PHARMACY/TRICARE/CHAMPVA: " ; PRCA*4.5*4.32 CHAMPVA, 41->38
S Y=Y_$S(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",RCTYPE="C":"CHAMPVA",1:"ALL") ; PRCA*4.5*4.32 CHAMPVA
S HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y="DATE RANGE: "_$P($$FMTE^XLFDT(START,2),"@")_" - "_$P($$FMTE^XLFDT(END,2),"@")_" (DATE EFT FILED)"
S Y=$J("",80-$L(Y)\2)_Y,HCNT=HCNT+1,RCHDR(HCNT)=Y
;
S Y="AGED",HCNT=HCNT+1,RCHDR(HCNT)=Y
; PRCA*4.5*318 moved deposit date up a row
S Y="DAYS TRACE # DEP DATE",HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y=" DEPOSIT FROM/ID",HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y=" FILE DATE DEPOSIT AMOUNT DEP#/EFT# DEPOSIT POST STATUS",HCNT=HCNT+1,RCHDR(HCNT)=Y ; PRCA*4.5*326
S Y="",$P(Y,"=",81)="",HCNT=HCNT+1,RCHDR(HCNT)=Y ; row of equal signs at bottom
;
S RCHDR(0)=HCNT
;
Q
;
HDRLM ; create the Listman header section
; returns RCHDR
; RCHDR(0) = header text line count
;INPUT:
; RCDTRNG - date range filter value to be printed as part of the header
; RCPAY - Payer filter value(s)
;
K RCHDR S RCPGNUM=0,RCSTOP=0
;
N START,END,MSG,DATE,Y,DIV,HCNT
S START=$$FMTE^XLFDT($P(RCDTRNG,U,2),2),END=$$FMTE^XLFDT($P(RCDTRNG,U,3),2)
S Y="DATE RANGE: "_$P($$FMTE^XLFDT(START,2),"@")_" - "_$P($$FMTE^XLFDT(END,2),"@")_" (DATE EFT FILED)"
S HCNT=1,RCHDR(HCNT)=Y
; Payer(s) - PRCA*4.5*326 Add MPT filter
S Y="PAYERS: "_$S(RCPAY="R":"RANGE",RCPAY="S":"SELECTED",1:"ALL")
S Y=$E(Y_$J("",80),1,38)_"MEDICAL/PHARMACY/TRICARE/CHAMPVA: " ; PRCA*4.5*4.32 CHAMPVA, 41->38
S Y=Y_$S(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",RCTYPE="C":"CHAMPVA",1:"ALL") ; PRCA*4.5*4.32 CHAMPVA
S HCNT=HCNT+1,RCHDR(HCNT)=Y
;
S HCNT=HCNT+1,RCHDR(HCNT)=""
S Y="AGED",HCNT=HCNT+1,RCHDR(HCNT)=Y
; PRCA*4.5*318 moved deposit date up a row
S Y="DAYS TRACE # DEP DATE",HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y=" DEPOSIT FROM/ID",HCNT=HCNT+1,RCHDR(HCNT)=Y
S Y=" FILE DATE DEPOSIT AMOUNT DEP#/EFT# DEPOSIT POST STATUS",HCNT=HCNT+1,RCHDR(HCNT)=Y ; PRCA*4.5*326
;
S RCHDR(0)=HCNT
;
Q
;
EXCEL ; Print report to screen, one record per line for export to MS Excel.
; RCTMPND = name of the subscript for ^TMP to use
W !!,"Aged Days^Trace #^Deposit From/ID^File Date^Deposit Amount^Dep#/EFT#^Deposit Post Status^Deposit Date" ; PRCA*4.5*326
S RCZ="" F S RCZ=$O(^TMP($J,"RCEFT_AGED",RCZ)) Q:RCZ="" S RCIEN=0 F S RCIEN=$O(^TMP($J,"RCEFT_AGED",RCZ,RCIEN)) Q:'RCIEN D G:RCSTOP PRTQ2
.I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W:RCTMPND="" !!,"***TASK STOPPED BY USER***" Q
.S RC0=$G(^RCY(344.31,RCIEN,0)),RC3443=$G(^RCY(344.3,+RC0,0))
.D DEBEFT^RCDPEARL(.RC0) ;Add minus sign for debit amounts PRCA*4.5*432
.N RCPAY S RCPAY=$P(RC0,U,2) S:RCPAY="" RCPAY="NO PAYER NAME RECEIVED" ; PRCA*4.5*298
.S Z=$J(-RCZ,4)_"^"_$P(RC0,U,4)_"^"_RCPAY_"/"_$P(RC0,U,3)_"^"_$S($P(RC0,U,13):$$FMTE^XLFDT($P(RC0,U,13),2),1:"")_"^" ; PRCA*4.5*298
.S Z=Z_$P(RC0,U,7)_"^"_$P(RC3443,U,6)_"/"_$P(RC0,U)_"."_$P(RC0,U,14)_"^" ; PRCA*4.5*326
.S Z=Z_$S($P(RC3443,U,12):"",1:"NOT ")_"Posted to 8NZZ"_$S($P(RC3443,U,12):"^"_$$FMTE^XLFDT($P(RC0,U,12),2),1:"") ; PRCA*4.5*326
.W !,Z
W !!,"*** END OF REPORT ***",!
;
PRTQ2 ;
I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ZTQUEUED) D ^%ZISC
K ^TMP($J,"RCEFT_AGED"),^TMP("RCSELPAY",$J),^TMP("RCPAYER",$J),^TMP($J,"RCERA_ADJ")
Q
;
;PRCA*4.5*298
; removed RCIND local variable
; changed RC00 to RC3443
; replaced SETLINE with SL^RCDPEARL
; added $$HDRNM
; added RCLSTMGR in checks for header
; changed upper case text to mixed case throughout
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEAR2 13532 printed Nov 22, 2024@16:54:36 Page 2
RCDPEAR2 ;ALB/TMK/PJH - EFT Unmatched Aging Report - FILE 344.3 ;Nov 24, 2014@18:31:57
+1 ;;4.5;Accounts Receivable;**173,269,276,284,283,293,298,318,321,326,432**;Mar 20, 1995;Build 16
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; PRCA*4.5*298 notes at bottom
EN1 ; option: EFT Unmatched Aging Report [RCDPE EFT AGING REPORT]
+1 NEW %ZIS,DIC,DIR,DTOUT,DUOUT,POP,RCDISPTY,RCDTRNG,RCEND,RCHDR
+2 NEW RCJOB1,RCLSTMGR,RCPAR,RCPAY,RCPGNUM,RCSTART,RCTMPND,RCTYPE,X,Y
+3 ; RCDISPTY = display type
+4 ; RCEND = end date
+5 ; RCLSTMGR = list manager flag
+6 ; RCTYPE = Type of payers to include M/P/T/C/A MEDICAL/PHARMACY/TRICARE/CHAMPVA/ALL
+7 ; RCDTRNG= "1^start date^end date"
+8 ; RCSTART = start date
+9 ; RCTMPND = name of the subscript for ^TMP to use
+10 ; RCPAY = A - All payers, S - Selected Payers, R - Range of Payers
+11 ;
+12 ; initial value
SET RCLSTMGR=""
+13 SET RCDTRNG=$$DTRNG^RCDPEM4()
if '(RCDTRNG>0)
GOTO EN1Q
+14 SET RCSTART=$PIECE(RCDTRNG,U,2)-1
SET RCEND=$PIECE(RCDTRNG,U,3)
+15 ;
+16 ; PRCA*4.5*326 - Ask to show Medical/Pharmacy Tricare or All ; PRCA*4.5*4.32 CHAMPVA
+17 SET RCTYPE=$$RTYPE^RCDPEU1("")
+18 IF RCTYPE=-1
GOTO EN1Q
+19 ;
+20 ; PRCA*4.5*326 - Selected or Range of Payers
SET RCPAY=$$PAYRNG^RCDPEU1()
+21 ; PRCA*4.5*326 '^' or timeout
IF RCPAY=-1
GOTO EN1Q
+22 ;
+23 ; PRCA*4.5*326 - Since we don't want all payers
IF RCPAY'="A"
Begin DoDot:1
+24 ; prompt for payers we do want
SET RCPAR("TYPE")=RCTYPE
+25 SET RCPAR("SELC")=RCPAY
+26 SET RCPAR("FILE")=344.31
+27 SET RCPAR("DICA")="Select Insurance Company NAME: "
+28 SET XX=$$SELPAY^RCDPEU1(.RCPAR)
End DoDot:1
IF XX=-1
GOTO EN1Q
+29 ;
+30 ;Get display type
+31 SET RCDISPTY=$$DISPTY^RCDPEM3()
if RCDISPTY<0
GOTO EN1Q
+32 ; display device info about Excel format, set ListMan flag to prevent question
+33 IF RCDISPTY
SET RCLSTMGR="^"
DO INFO^RCDPEM6
+34 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO EN1Q
+35 ;
+36 ; if not output to Excel ask for ListMan display, exit if timeout or '^' - PRCA*4.5*298
+37 IF RCLSTMGR=""
SET RCLSTMGR=$$ASKLM^RCDPEARL
IF RCLSTMGR<0
GOTO EN1Q
+38 ; display in ListMan format and exit on return
+39 IF RCLSTMGR
Begin DoDot:1
+40 ; clean any residue
SET RCTMPND=$TEXT(+0)_"^EFT UNMATCHED AGING"
KILL ^TMP($JOB,RCTMPND)
+41 DO RPTOUT
+42 NEW H,L,HDR
SET L=0
+43 SET HDR("TITLE")=$$HDRNM
+44 ; take first 3 lines of report header
FOR H=1:1:7
IF $DATA(RCHDR(H))
SET L=H
SET HDR(H)=RCHDR(H)
+45 ; any remaining header lines at top of report
IF $ORDER(RCHDR(L))
Begin DoDot:2
+46 NEW N
SET N=0
SET H=L
FOR
SET H=$ORDER(RCHDR(H))
if 'H
QUIT
SET N=N+.001
SET ^TMP($JOB,RCTMPND,N)=RCHDR(H)
End DoDot:2
+47 ; generate ListMan display
DO LMRPT^RCDPEARL(.HDR,$NAME(^TMP($JOB,RCTMPND)))
End DoDot:1
GOTO EN1Q
+48 ;
+49 SET RCTMPND=""
+50 ; Ask device
+51 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EN1Q
+52 IF $DATA(IO("Q"))
Begin DoDot:1
+53 NEW ZTDESC,ZTRTN,ZTSAVE,ZTSTOP
+54 SET ZTRTN="RPTOUT^RCDPEAR2"
SET ZTDESC="EFT AGING REPORT"
+55 SET ZTSAVE("RC*")=""
SET ZTSAVE("VAUTD")=""
+56 ; PRCA*4.5*326
SET ZTSAVE("^TMP(""RCDPEU1"",$J,")=""
+57 DO ^%ZTLOAD
+58 WRITE !!,$SELECT($GET(ZTSK):"Task number "_ZTSK_" has been queued.",1:"Unable to queue this task.")
+59 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO EN1Q
+60 ;
+61 USE IO
DO RPTOUT
+62 ;
EN1Q ; exit and clean up
+1 IF 'RCLSTMGR
DO ^%ZISC
+2 ; PRCA*4.5*326
KILL ^TMP("RCSELPAY",$JOB),^TMP("RCPAYER",$JOB),^TMP("RCDPEU1",$JOB)
+3 QUIT
+4 ;
RPTOUT ; Entry point for queued job, nightly job
+1 ; RCTMPND = name of the subscript for ^TMP to use to return all lines
+2 ; If undefined or null, output is printed
+3 ; Return global if RCTMPND not null: ^TMP($J,RCTMPND,line#)=line text
+4 NEW DIC,DUOUT,RC0,RC13,RC3443,RCCT,RCIEN,RCNT,RCOUT,RCPAYER,RCPAYID
+5 NEW RCSTOP,RCTOT,RCZ,X,XX,YY,Z,Z0,ZZ
+6 SET RCTMPND=$GET(RCTMPND)
+7 SET (RCCT,RCSTOP,RCNT,RCTOT)=0
+8 KILL ^TMP($JOB,"RCERA_AGED"),^TMP($JOB,"RCERA_ADJ")
+9 ; build local payer array here
+10 IF RCTMPND'=""
KILL ^TMP($JOB,RCTMPND)
+11 ; cross-ref on file #344.31 field #.08 - MATCH STATUS
+12 ;unmatched entries only
SET RCIEN=0
FOR
SET RCIEN=$ORDER(^RCY(344.31,"AMATCH",0,RCIEN))
if 'RCIEN
QUIT
Begin DoDot:1
+13 ; EFT has been removed
if $PIECE($GET(^RCY(344.31,RCIEN,3)),U)
QUIT
+14 ; payment of zero
if $PIECE($GET(^RCY(344.31,RCIEN,0)),U,7)=0
QUIT
+15 ;
+16 ; date received
SET RC13=$PIECE($GET(^RCY(344.31,RCIEN,0)),U,13)
+17 ; Check for payer match
+18 IF RCPAY'="A"
Begin DoDot:2
+19 ; PRCA*4.5*326 Check if payer was selected
SET XX=$$ISSEL^RCDPEU1(344.31,RCIEN)
End DoDot:2
if 'XX
QUIT
+20 ; If all of a give type of payer selected
IF '$TEST
IF RCTYPE'="A"
Begin DoDot:2
+21 ; check that payer matches type
SET XX=$$ISTYPE^RCDPEU1(344.31,RCIEN,RCTYPE)
End DoDot:2
if 'XX
QUIT
+22 ; Check date range
+23 if (RCSTART>RC13)!(RC13>RCEND)
QUIT
+24 ; Passed all the filters - include on report
+25 SET ^TMP($JOB,"RCEFT_AGED",$$FMDIFF^XLFDT(RC13,DT),RCIEN)=0
SET RCNT=RCNT+1
End DoDot:1
+26 ;
+27 ; create header
if 'RCLSTMGR
DO HDRBLD
+28 ; create Listman header
if RCLSTMGR
DO HDRLM
+29 ;
+30 IF RCDISPTY
DO EXCEL
QUIT
+31 ;
+32 ; Find total amount of EFTs
+33 SET RCZ=""
FOR
SET RCZ=$ORDER(^TMP($JOB,"RCEFT_AGED",RCZ))
if RCZ=""
QUIT
SET RCIEN=0
FOR
SET RCIEN=$ORDER(^TMP($JOB,"RCEFT_AGED",RCZ,RCIEN))
if 'RCIEN
QUIT
Begin DoDot:1
+34 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (RCSTOP,ZTSTOP)=1
KILL ZTREQ
IF +$GET(RCPGNUM)
if RCTMPND=""
WRITE !!,"***TASK STOPPED BY USER***"
QUIT
+35 SET RC0=$GET(^RCY(344.31,RCIEN,0))
SET RC3443=$GET(^RCY(344.3,+RC0,0))
+36 ;Add minus sign for debit amounts PRCA*4.5*432
DO DEBEFT^RCDPEARL(.RC0)
+37 SET RCTOT=RCTOT+$PIECE(RC0,U,7)
End DoDot:1
if RCSTOP
GOTO PRTQ
+38 ;
+39 ; initial report header
if 'RCLSTMGR
DO HDRLST^RCDPEARL(.RCSTOP,.RCHDR)
+40 ;
+41 SET Z=$$SETSTR^VALM1("Totals:","",1,79)
+42 DO SL^RCDPEARL(Z,.RCCT,RCTMPND)
+43 SET Z=$$SETSTR^VALM1(" Number Aged Electronic EFT Messages Found: "_RCNT,"",1,79)
+44 DO SL^RCDPEARL(Z,.RCCT,RCTMPND)
+45 SET Z=$$SETSTR^VALM1(" Amount Aged Electronic EFT Messages Found: $"_$FNUMBER(+RCTOT,",",2),"",1,79)
+46 DO SL^RCDPEARL(Z,.RCCT,RCTMPND)
+47 DO SL^RCDPEARL($TRANSLATE($JUSTIFY("",IOM)," ","="),.RCCT,RCTMPND)
+48 ;
+49 SET RCZ=""
FOR
SET RCZ=$ORDER(^TMP($JOB,"RCEFT_AGED",RCZ))
if RCZ=""
QUIT
SET RCIEN=0
FOR
SET RCIEN=$ORDER(^TMP($JOB,"RCEFT_AGED",RCZ,RCIEN))
if 'RCIEN
QUIT
Begin DoDot:1
+50 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (RCSTOP,ZTSTOP)=1
KILL ZTREQ
IF +$GET(RCPGNUM)
if RCTMPND=""
WRITE !!,"***TASK STOPPED BY USER***"
QUIT
+51 ; On detail list, skip line
IF RCPGNUM
DO SL^RCDPEARL(" ",.RCCT,.RCTMPND)
+52 IF 'RCLSTMGR
IF $Y>(IOSL-RCHDR(0))
DO HDRLST^RCDPEARL(.RCSTOP,.RCHDR)
if RCSTOP
QUIT
+53 SET RC0=$GET(^RCY(344.31,RCIEN,0))
SET RC3443=$GET(^RCY(344.3,+RC0,0))
+54 ;Add minus sign for debit amounts PRCA*4.5*432
DO DEBEFT^RCDPEARL(.RC0)
+55 SET RCTOT=RCTOT+$PIECE(RC0,U,7)
+56 SET Z=$$SETSTR^VALM1($JUSTIFY(-RCZ,4),"",1,4)
+57 ; PRCA*4.5*318 moved deposit date up a row to give more room for payer/payer ID
+58 ;trace#
SET Z=$$SETSTR^VALM1(" "_$PIECE(RC0,U,4),Z,5,52)
+59 ; deposit date
SET Z=$$SETSTR^VALM1($$FMTE^XLFDT($PIECE(RC0,U,12),2),Z,73,8)
+60 DO SL^RCDPEARL(Z,.RCCT,RCTMPND)
+61 ; PRCA*4.5*298
NEW RCPAY
SET RCPAY=$PIECE(RC0,U,2)
if RCPAY=""
SET RCPAY="NO PAYER NAME RECEIVED"
+62 ; Payer ID ;PRCA*4.5*298
SET RCPAYID=$PIECE(RC0,U,3)
+63 ;PRCA*4.5*318 dynamically display payer name/ID based on length
+64 SET RCPAYER=RCPAY_"/"_RCPAYID
+65 IF $LENGTH(RCPAYER)>76
Begin DoDot:2
+66 SET ZZ=$LENGTH(RCPAYER,"/")
SET XX=$PIECE(RCPAYER,"/",1,ZZ-1)
SET YY=$PIECE(RCPAYER,"/",ZZ)
+67 SET XX=$EXTRACT(RCPAYER,1,$LENGTH(XX)-($LENGTH(RCPAYER)-76))
SET RCPAYER=XX_"/"_YY
End DoDot:2
+68 ; PRCA*4.5*298 (payer/payer ID)
SET Z=$$SETSTR^VALM1(RCPAYER,"",5,76)
+69 ;S Z=$$SETSTR^VALM1(" "_$$FMTE^XLFDT($P(RC0,U,12),2),Z,70,10) ; deposit date
+70 ;end of PRCA*4.5*318 display change
+71 DO SL^RCDPEARL(Z,.RCCT,RCTMPND)
+72 SET Z=$$SETSTR^VALM1($JUSTIFY("",6)_$SELECT($PIECE(RC0,U,13):$$FMTE^XLFDT($PIECE(RC0,U,13),2),1:""),"",1,17)
+73 SET Z=$$SETSTR^VALM1(" "_$JUSTIFY($PIECE(RC0,U,7),15,2),Z,18,17)
+74 ; PRCA*4.5*283 - change length from 8 to 11 to allow for 9 digit DEP #'s
+75 ; PRCA*4.5*326 - add EFT identifier
+76 SET Z=$$SETSTR^VALM1(" "_$PIECE(RC3443,U,6)_"/"_$$GET1^DIQ(344.31,RCIEN_",",.01,"E"),Z,35,17)
+77 SET Z=$$SETSTR^VALM1(" "_$SELECT($PIECE(RC3443,U,12):"",1:"NOT ")_"Posted to 8NZZ"_$SELECT($PIECE(RC3443,U,12):" "_$$FMTE^XLFDT($PIECE(RC3443,U,11),2),1:""),Z,52,36)
+78 DO SL^RCDPEARL(Z,.RCCT,RCTMPND)
+79 KILL RCOUT
+80 DO GETS^DIQ(344.31,RCIEN_",",2,"E","RCOUT")
+81 if '$ORDER(RCOUT(344.31,RCIEN_",",2,0))
QUIT
+82 DO SL^RCDPEARL($JUSTIFY("",8)_"--EXCEPTION NOTES--",.RCCT,RCTMPND)
+83 SET Z=0
FOR
SET Z=$ORDER(RCOUT(344.31,RCIEN_",",2,Z))
if 'Z
QUIT
Begin DoDot:2
+84 IF 'RCLSTMGR
IF $Y>(IOSL-RCHDR(0))
DO HDRLST^RCDPEARL(.RCSTOP,.RCHDR)
if RCSTOP
QUIT
+85 DO SL^RCDPEARL($JUSTIFY("",8)_" "_RCOUT(344.31,RCIEN_",",2,Z),.RCCT,RCTMPND)
End DoDot:2
if RCSTOP
QUIT
End DoDot:1
if RCSTOP
GOTO PRTQ
+86 ;
+87 ;
+88 ; PRCA*4.5*298, put end-of-report into SL^RCDPEARL
+89 ; skip a line
DO SL^RCDPEARL(" ",.RCCT,RCTMPND)
+90 DO SL^RCDPEARL($$ENDORPRT^RCDPEARL,.RCCT,RCTMPND)
+91 ;
PRTQ ;
+1 ; PRCA*4.5*298, added ListMan check
+2 IF '$DATA(ZTQUEUED)
IF 'RCLSTMGR
IF 'RCSTOP
DO ASK^RCDPEARL(.RCSTOP)
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+5 KILL ^TMP($JOB,"RCEFT_AGED"),ZTQUEUED
+6 ; PRCA*4.5*326
KILL ^TMP("RCDPEU1",$JOB)
+7 QUIT
+8 ;
+9 ; extrinsic variable, text for header PRCA*4.5*298
HDRNM() QUIT "EFT UNMATCHED AGING REPORT"
+1 ;
HDRBLD ; create the report header
+1 ; returns RCHDR, RCPGNUM, RCSTOP
+2 ; RCHDR(0) = header text line count
+3 ; RCHDR("XECUTE") = M code for page number
+4 ; RCHDR("RUNDATE") = date/time report generated, external format
+5 ; RCPGNUM - page counter
+6 ; RCSTOP - flag to exit
+7 ;INPUT:
+8 ; RCDTRNG - date range filter value to be printed as part of the header
+9 ; RCPAY - Payer filter value(s)
+10 ; RCLSTMGR
+11 ;
+12 KILL RCHDR
SET RCHDR("RUNDATE")=$$NOW^RCDPEARL
SET RCPGNUM=0
SET RCSTOP=0
+13 ;
+14 ; Excel format, xecute code is QUIT, null page number
IF RCDISPTY
Begin DoDot:1
+15 SET RCHDR(0)=1
SET RCHDR("XECUTE")="Q"
SET RCPGNUM=""
+16 ; PRCA*4.3*326
SET RCHDR(1)="Aged Days^Trace #^Deposit From/ID^File Date^Deposit Amount^Dep#/EFT#^Deposit Post Status^Deposit Date"
End DoDot:1
QUIT
+17 ;
+18 NEW START,END,MSG,DATE,Y,DIV,HCNT
+19 SET START=$$FMTE^XLFDT($PIECE(RCDTRNG,U,2),2)
SET END=$$FMTE^XLFDT($PIECE(RCDTRNG,U,3),2)
+20 ;
+21 ; line 1 will be replaced by XECUTE code below
SET Y=$$HDRNM
SET HCNT=1
SET RCHDR(HCNT)=$JUSTIFY("",80-$LENGTH(Y)\2)_Y
+22 SET RCHDR("XECUTE")="N Y S RCPGNUM=RCPGNUM+1,Y=$$HDRNM^"_$TEXT(+0)_"_$S(RCLSTMGR:"""",1:$J(""Page: ""_RCPGNUM,12)),RCHDR(1)=$J("" "",80-$L(Y)\2)_Y"
+23 ; line 1 will be replaced by XECUTE code below
SET Y="RUN DATE: "_RCHDR("RUNDATE")
SET HCNT=HCNT+1
SET RCHDR(HCNT)=$JUSTIFY("",80-$LENGTH(Y)\2)_Y
+24 ;
+25 ; Payer(s) - PRCA*4.5*326 Add MPT filter
+26 SET Y="PAYERS: "_$SELECT(RCPAY="R":"RANGE",RCPAY="S":"SELECTED",1:"ALL")
+27 ; PRCA*4.5*4.32 CHAMPVA, 41->38
SET Y=$EXTRACT(Y_$JUSTIFY("",80),1,38)_"MEDICAL/PHARMACY/TRICARE/CHAMPVA: "
+28 ; PRCA*4.5*4.32 CHAMPVA
SET Y=Y_$SELECT(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",RCTYPE="C":"CHAMPVA",1:"ALL")
+29 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+30 SET Y="DATE RANGE: "_$PIECE($$FMTE^XLFDT(START,2),"@")_" - "_$PIECE($$FMTE^XLFDT(END,2),"@")_" (DATE EFT FILED)"
+31 SET Y=$JUSTIFY("",80-$LENGTH(Y)\2)_Y
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+32 ;
+33 SET Y="AGED"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+34 ; PRCA*4.5*318 moved deposit date up a row
+35 SET Y="DAYS TRACE # DEP DATE"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+36 SET Y=" DEPOSIT FROM/ID"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+37 ; PRCA*4.5*326
SET Y=" FILE DATE DEPOSIT AMOUNT DEP#/EFT# DEPOSIT POST STATUS"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+38 ; row of equal signs at bottom
SET Y=""
SET $PIECE(Y,"=",81)=""
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+39 ;
+40 SET RCHDR(0)=HCNT
+41 ;
+42 QUIT
+43 ;
HDRLM ; create the Listman header section
+1 ; returns RCHDR
+2 ; RCHDR(0) = header text line count
+3 ;INPUT:
+4 ; RCDTRNG - date range filter value to be printed as part of the header
+5 ; RCPAY - Payer filter value(s)
+6 ;
+7 KILL RCHDR
SET RCPGNUM=0
SET RCSTOP=0
+8 ;
+9 NEW START,END,MSG,DATE,Y,DIV,HCNT
+10 SET START=$$FMTE^XLFDT($PIECE(RCDTRNG,U,2),2)
SET END=$$FMTE^XLFDT($PIECE(RCDTRNG,U,3),2)
+11 SET Y="DATE RANGE: "_$PIECE($$FMTE^XLFDT(START,2),"@")_" - "_$PIECE($$FMTE^XLFDT(END,2),"@")_" (DATE EFT FILED)"
+12 SET HCNT=1
SET RCHDR(HCNT)=Y
+13 ; Payer(s) - PRCA*4.5*326 Add MPT filter
+14 SET Y="PAYERS: "_$SELECT(RCPAY="R":"RANGE",RCPAY="S":"SELECTED",1:"ALL")
+15 ; PRCA*4.5*4.32 CHAMPVA, 41->38
SET Y=$EXTRACT(Y_$JUSTIFY("",80),1,38)_"MEDICAL/PHARMACY/TRICARE/CHAMPVA: "
+16 ; PRCA*4.5*4.32 CHAMPVA
SET Y=Y_$SELECT(RCTYPE="M":"MEDICAL",RCTYPE="P":"PHARMACY",RCTYPE="T":"TRICARE",RCTYPE="C":"CHAMPVA",1:"ALL")
+17 SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+18 ;
+19 SET HCNT=HCNT+1
SET RCHDR(HCNT)=""
+20 SET Y="AGED"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+21 ; PRCA*4.5*318 moved deposit date up a row
+22 SET Y="DAYS TRACE # DEP DATE"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+23 SET Y=" DEPOSIT FROM/ID"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+24 ; PRCA*4.5*326
SET Y=" FILE DATE DEPOSIT AMOUNT DEP#/EFT# DEPOSIT POST STATUS"
SET HCNT=HCNT+1
SET RCHDR(HCNT)=Y
+25 ;
+26 SET RCHDR(0)=HCNT
+27 ;
+28 QUIT
+29 ;
EXCEL ; Print report to screen, one record per line for export to MS Excel.
+1 ; RCTMPND = name of the subscript for ^TMP to use
+2 ; PRCA*4.5*326
WRITE !!,"Aged Days^Trace #^Deposit From/ID^File Date^Deposit Amount^Dep#/EFT#^Deposit Post Status^Deposit Date"
+3 SET RCZ=""
FOR
SET RCZ=$ORDER(^TMP($JOB,"RCEFT_AGED",RCZ))
if RCZ=""
QUIT
SET RCIEN=0
FOR
SET RCIEN=$ORDER(^TMP($JOB,"RCEFT_AGED",RCZ,RCIEN))
if 'RCIEN
QUIT
Begin DoDot:1
+4 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (RCSTOP,ZTSTOP)=1
KILL ZTREQ
IF +$GET(RCPG)
if RCTMPND=""
WRITE !!,"***TASK STOPPED BY USER***"
QUIT
+5 SET RC0=$GET(^RCY(344.31,RCIEN,0))
SET RC3443=$GET(^RCY(344.3,+RC0,0))
+6 ;Add minus sign for debit amounts PRCA*4.5*432
DO DEBEFT^RCDPEARL(.RC0)
+7 ; PRCA*4.5*298
NEW RCPAY
SET RCPAY=$PIECE(RC0,U,2)
if RCPAY=""
SET RCPAY="NO PAYER NAME RECEIVED"
+8 ; PRCA*4.5*298
SET Z=$JUSTIFY(-RCZ,4)_"^"_$PIECE(RC0,U,4)_"^"_RCPAY_"/"_$PIECE(RC0,U,3)_"^"_$SELECT($PIECE(RC0,U,13):$$FMTE^XLFDT($PIECE(RC0,U,13),2),1:"")_"^"
+9 ; PRCA*4.5*326
SET Z=Z_$PIECE(RC0,U,7)_"^"_$PIECE(RC3443,U,6)_"/"_$PIECE(RC0,U)_"."_$PIECE(RC0,U,14)_"^"
+10 ; PRCA*4.5*326
SET Z=Z_$SELECT($PIECE(RC3443,U,12):"",1:"NOT ")_"Posted to 8NZZ"_$SELECT($PIECE(RC3443,U,12):"^"_$$FMTE^XLFDT($PIECE(RC0,U,12),2),1:"")
+11 WRITE !,Z
End DoDot:1
if RCSTOP
GOTO PRTQ2
+12 WRITE !!,"*** END OF REPORT ***",!
+13 ;
PRTQ2 ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+3 KILL ^TMP($JOB,"RCEFT_AGED"),^TMP("RCSELPAY",$JOB),^TMP("RCPAYER",$JOB),^TMP($JOB,"RCERA_ADJ")
+4 QUIT
+5 ;
+6 ;PRCA*4.5*298
+7 ; removed RCIND local variable
+8 ; changed RC00 to RC3443
+9 ; replaced SETLINE with SL^RCDPEARL
+10 ; added $$HDRNM
+11 ; added RCLSTMGR in checks for header
+12 ; changed upper case text to mixed case throughout
+13 ;
