RCDPCRR ;ALB/TJB - CARC/RARC DATA TABLE REPORT ;11/03/14 1:00pm
;;4.5;Accounts Receivable;**303**;Mar 20, 1995;Build 84
;;Per VA Directive 6402, this routine should not be modified.
Q
; PRCA*4.5*303 - CARC/RARC DATA Table report
;
; DESCRIPTION : The following generates a report that displays selected or all
; CARC or RARC Codes from the Files 345 (CARC) or 346 (RARC).
; several filters may be used to limit the codes displayed:
; * CARCs only, RARCs only or Both - default is both.
; * Display Active, Inactive or Both - default is active
; * Report Date - default today
; * Output to excel (Yes/No) - default is no
;
; INPUTS : The user is prompted for the following:
; CARC/RARC/Both Codes
; Prompt for codes to display
; Active/Inactive
; Report Date
; Output report to Excel
;
EN ; Entry point for Report
N DUOUT,DTOUT,DIR,X,Y,Z,I,JJ,KK,DL,CD,EXLN,IX,RCDT1,RCDET,ZTRTN,ZTSK,ZTDESC,ZTSAVE,ZTSTOP,%ZIS,POP
N RCJOB,RCCD,RCRD,RCNOW,RCODE,RCSTAT,RCPG,RCHR,RCDISP,IDX,TY,FILE,IEN,ZN,RCQUIT,XCNT
S RCQUIT=0
;
; Quick Search
G:$G(QS)'=1 R1 ; Go to regular report
;
D GCD(.RCCD,.RCDET)
I $G(RCCD)="EXIT" G ARCQ
S RCDISP=0,RCSTAT="B",RCDT1=$$DT^XLFDT K ^TMP("RC_CARC_RARC_TABLE",$J)
D GETCODES($G(RCCD("CARC")),$G(RCCD("RARC")),RCSTAT,RCDT1,$NA(^TMP("RC_CARC_RARC_TABLE",$J)))
S RCODE="CARC^RARC",RCNOW=$$NOW^RCDPRU(),RCPG=0,$P(RCHR,"=",IOM)="" ;,IOSL=40
G REPORT
;
R1 ;
S RCODE=""
S DIR("A")="Select (N)o CARCs or (A)ll CARCs?: ",DIR(0)="SA^N:No CARCs to Include;A:All CARCs Included"
S DIR("B")="ALL" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G ARCQ
S RCDET=$$UP(Y)
I RCDET="A" S RCCD("CARC")="ALL",RCODE="CARC"
;
S DIR("A")="Select (N)o RARCs or (A)ll RARCs?: ",DIR(0)="SA^N:No RARCs to Include;A:All RARCs Included"
S DIR("B")="ALL" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G ARCQ
S RCDET=$$UP(Y)
I RCDET="A" S RCRD("RARC")="ALL",RCODE=$S(RCODE'="":RCODE_"^RARC",1:"RARC")
;
I RCODE']"" W !!,"Error: No Codes selected for display...",!,"Please select either CARC and/or RARC to include on report",! G R1
;
S DIR("A")="Include (A)ctive codes, (I)nactive codes or (B)oth?: ",DIR(0)="SA^A:ACTIVE Codes;I:INACTIVE Codes;B:BOTH ACTIVE/INACTIVE Codes"
S DIR("?")="Active/Inactive will be based on the date selected."
S DIR("?",1)="Please indicate Active/Inactive/Both for codes included on the report."
S DIR("?",2)="Active and Inactive codes will be determined by the date of the report."
S DIR("B")="ACTIVE" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G ARCQ
S RCSTAT=$$UP(Y)
;
DT1 ; Check the date
S DIR("?")="Enter Date for the report"
S DIR(0)="DAO^:"_DT_":APE",DIR("B")="T",DIR("A")="Report Date: " D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") G ARCQ
S RCDT1=Y
I RCDT1<2950102 W !,"Invalid date entered, no records for report.",!,"Please select a date after 1/1/1995.",! G DT1
;
W !
; Send output to excel. (Removed excel output because description would be truncated)
S RCDISP=0
;S RCDISP=$$DISPTY^RCDPRU()
;D:RCDISP INFO^RCDPRU
;
S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTRTN="ENQ^RCDPCRR",ZTDESC="AR - CARC & RARC DATA REPORT",ZTSAVE("*")=""
. D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
. K ZTSK,IO("Q") D HOME^%ZIS
U IO
;
ENQ ; Return here for queued print
S RCNOW=$$NOW^RCDPRU(),RCPG=0,$P(RCHR,"=",IOM)=""
;
K ^TMP("RC_CARC_RARC_TABLE",$J)
D GETCODES($G(RCCD("CARC")),$G(RCRD("RARC")),RCSTAT,RCDT1,$NA(^TMP("RC_CARC_RARC_TABLE",$J)))
;
REPORT ;
; Report
I RCDISP=0 D
. S RCPG=1 W @IOF
. I $G(QS)=1 D HDRP("EDI LOCKBOX CARC/RARC QUICK SEARCH",1,"Page: "_RCPG)
. E D HDRP("EDI LOCKBOX CARC/RARC TABLE DATA REPORT",1,"Page: "_RCPG)
. D HDRP("REPORT RUN DATE: "_RCNOW,1)
. D:+$G(QS)'=1 HDRP($$HDR2(RCSTAT,RCDET,RCDT1),1) W !!
. W $$HDR3(),!
. W RCHR,! S RCSL=8
E W "CODE^START^STOP^MODIFIED^VDATE^TYPE^DESCRIPTION^NOTES",!
S IDX=RCODE
F JJ=1:1 S TY=$P(IDX,U,JJ),CD="" Q:TY=""!RCQUIT S FILE=$S(TY="RARC":346,1:345) F S CD=$O(^TMP("RC_CARC_RARC_TABLE",$J,TY,CD)) Q:CD=""!RCQUIT D
. S IEN="",IEN=$O(^TMP("RC_CARC_RARC_TABLE",$J,TY,CD,IEN)),ZN=$G(^TMP("RC_CARC_RARC_TABLE",$J,TY,CD,IEN))
. K RCDAT,RCERR
. D GETS^DIQ(FILE,IEN_",","4;5","","RCDAT","RCERR") ; Get Description (4) and Notes (5) fields
. I RCDISP D ; Output Excel
.. S EXLN=$P(ZN,U,1)_U_$$DATE($P(ZN,U,2))
.. S EXLN=EXLN_U_$S($P(ZN,U,3)="":"",1:$$DATE($P(ZN,U,3)))_U_$S($P(ZN,U,4)="":"",1:$$DATE($P(ZN,U,4)))_U_$S($P(ZN,U,5)="":"",1:$$DATE($P($P(ZN,U,5),".",1)))_U_TY
.. ; Collect Discription into a single variable for output
.. S KK="",DL=""
.. F S KK=$O(RCDAT(FILE,IEN_",",4,KK)) Q:KK="" S DL=DL_$G(RCDAT(FILE,IEN_",",4,KK))
.. S EXLN=EXLN_U_DL
.. ;Add notes
.. S EXLN=EXLN_U_$G(RCDAT(FILE,IEN_",",5))
.. W EXLN,!
. E D ; Output to the screen
.. W ?(4-$L($P(ZN,U,1))),$P(ZN,U,1),?8,$$DATE($P(ZN,U,2))
.. W:$P(ZN,U,3)'="" ?21,$$DATE($P(ZN,U,3)) W:$P(ZN,U,4)'="" ?35,$$DATE($P(ZN,U,4)) W ?51,TY W:$P(ZN,U,5)'="" ?64,$$DATE($P($P(ZN,U,5),".",1)) W ! S RCSL=RCSL+1
.. I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL) G:RCQUIT ARCQ
.. ;Accumulate the Word Processing Description Field
.. S IX="",XCNT=0 K ^UTILITY($J,"W")
.. F S IX=$O(RCDAT(FILE,IEN_",",4,IX)) Q:IX="" S X=RCDAT(FILE,IEN_",",4,IX),DIWL=6,DIWR=IOM,DIWF="W" D ^DIWP S RCSL=RCSL+1 I RCSL>=(IOSL-2) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL) G:RCQUIT ARCQ
.. D ^DIWW S RCSL=RCSL+1
.. I RCSL>=(IOSL-3) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL) G:RCQUIT ARCQ
.. ;Print the Notes Field
.. I $G(RCDAT(FILE,IEN_",",5))'="" K ^UTILITY($J,"W") S X="NOTES: "_RCDAT(FILE,IEN_",",5),DIWL=6,DIWR=IOM,DIWF="" D ^DIWP,^DIWW S RCSL=RCSL+1
.. W ! S RCSL=RCSL+1
.. I RCSL>=(IOSL-3) S RCQUIT=$$NEWPG(.RCPG,0,.RCSL) G:RCQUIT ARCQ
;
D:'RCQUIT ASK^RCDPRU(.RCSTOP)
ARCQ ; Clean up and quit
K DHDR,RCEXCEL,RCLIST,RCODE,DIWL,DIWR,DIWF,IX,DATA,ERROR,QS
K ^TMP("RC_CARC_RARC_TABLE",$J)
Q
;
GETCODES(CARC,RARC,STAT,RDT,ARRAY,DESC) ;
; CARC = CARC data to retrieve
; RARC = RARC data to retrieve
; CARC and RARC can be a single code, a list of codes, range or combination.
; STAT = Retrieve Active, Inactive or Both codes
; RDT = Report date (used to determine Active/Inactive status)
; ARRAY = Stuff the data into ARRAY passed for as a string for indirection
; DESC (optional) = Add description to ARRAY, second ^ is length, if
; undefined or less than 10 characters description
; length will be 10 characters, maximum is 250 characters
I $G(DESC)="" S DESC=0
I CARC]"" D ELEM("CARC",345,CARC,STAT,RDT,.ARRAY,DESC)
I RARC]"" D ELEM("RARC",346,RARC,STAT,RDT,.ARRAY,DESC)
Q
;
ELEM(TYPE,FILE,DAT,STAT,RDT,ARRAY,DESC) ;
N I,OKAY,R1,R2,RX,RY,RZ,O1,ELEM,DATA,START,STOP,DL,RCZT S DL=""
I $G(DESC)'=0 S DL=$P(DESC,U,2) S:+$G(DL)<10 DL=10 S:$G(DL)>250 DL=250
I DAT="ALL" S R1=$O(^RC(FILE,"B","")),R2=$O(^RC(FILE,"B",""),-1),DAT=R1_":"_R2
F I=1:1 S ELEM=$P(DAT,",",I) Q:ELEM="" D
. I ELEM[":" D ; Range
.. S R1=$P(ELEM,":",1),R2=$P(ELEM,":",2),RX=$O(^RC(FILE,"B",R1),-1)
.. F S RX=$O(^RC(FILE,"B",RX)) Q:(RX]]R2)!(RX="") D
... S O1=$O(^RC(FILE,"B",RX,"")),DATA=^RC(FILE,O1,0),START=$P(DATA,U,2),STOP=$P(DATA,U,3)
... D:DL'=""
.... ; Get description if wanted
.... K RCZT S RY=$$GET1^DIQ(FILE,O1_",",4,"","RCZT"),RY="",RZ="" F S RZ=$O(RCZT(RZ)) Q:RZ="" S RY=RY_RCZT(RZ)_" "
.... S RY=$E(RY,1,DL)
... ;S OKAY=$S(STAT="B":1,STAT="I":$S(STOP="":0,STOP<=RDT:1,1:0),STAT="A":$S(STOP="":1,STOP>RDT:1,STOP<=RDT:0,1:0))
... S OKAY=$$STAT(STAT,RDT,STOP,START)
... S:OKAY @ARRAY@(TYPE,RX,O1)=DATA S:OKAY&(DL'="") @ARRAY@(TYPE,RX,O1)=@ARRAY@(TYPE,RX,O1)_U_RY
. E D
.. ;Add an individual code
.. S O1=$O(^RC(FILE,"B",ELEM,"")),DATA=^RC(FILE,O1,0),START=$P(DATA,U,2),STOP=$P(DATA,U,3)
.. D:DL'=""
... ; Get description if wanted
... K RCZT S RY=$$GET1^DIQ(FILE,O1_",",4,"","RCZT"),RY="",RZ="" F S RZ=$O(RCZT(RZ)) Q:RZ="" S RY=RY_RCZT(RZ)_" "
... S RY=$E(RY,1,DL)
.. ;S OKAY=$S(STAT="B":1,STAT="I":$S(STOP="":0,STOP<=RDT:1,1:0),STAT="A":$S(STOP="":1,STOP>RDT:1,STOP<=RDT:0,1:0))
.. S OKAY=$$STAT(STAT,RDT,STOP,START)
.. S:OKAY @ARRAY@(TYPE,ELEM,O1)=DATA S:OKAY&(DL'="") @ARRAY@(TYPE,ELEM,O1)=@ARRAY@(TYPE,ELEM,O1)_U_RY
Q
;
STAT(INC,ZDT,SP,ST) ; Determine if this code should be included in report
; INC = Active, Inactive, Both; ZDT = Date of report ; ST = Start date of code ; SP = Stop Date of code
N RET S RET=0
I $G(INC)="B" S:($G(ZDT)>$G(ST)) RET=1 Q RET ; Both active and inactive and start date before report date
I $G(INC)="I" S RET=0 D Q RET ; Inactive codes
. I $G(SP)="" S RET=0 Q ; No stop date can't be inactive
. I ($G(ZDT)>$G(SP)),($G(ZDT)>$G(ST)) S RET=1 Q ; Inactive, Stop before report and Start date before report date
I $G(INC)="A" S RET=0 D Q RET
. I $G(ZDT)>$G(ST),($G(SP)="") S RET=1 Q ; Active, Start date before report date and no stop date
. I $G(ZDT)>$G(ST),($G(SP)>$G(ZDT)) S RET=1 Q ; Active, Start date before report date and stop date after report date
Q 0 ; Return do not include
;
GCARC(RET) ; Get CARC data elements for report
N RCLIST,RCODE,DTOUT,DUOUT,FILE
S FILE=345
S DIR("A")="Select (C)ARC, (R)ange of CARCs or (A)ll ?: ",DIR(0)="SA^A:All CARCs;C:Single CARC;R:Range/List of CARCs"
S DIR("B")="ALL" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S RCSTOP=1 Q
S RCLIST=Y
I RCLIST="A" S RET("CARC")="ALL" Q
I RCLIST="C" D Q
.; if invalid code return here
C1 .;
. S DIR("A")="Enter a CARC code",DIR(0)="P^345;EABZ" ;F^1:200"
. S DIR("?")="Only a single codes can be entered as: A1"
. S DIR("?",1)="Please enter one CARC code for the report."
. S DIR("?",2)="The single validated code will be included in the report."
. S DIR("??")="^D LIST^RCDPCRR(345)"
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!(Y="") S RCSTOP=1 Q
. S RCODE=$$UP(X)
. I (RCODE[":"),(RCODE["-"),(RCODE[",") W !!,"Code: "_RCODE_" not found. Please try again...",! S X="",RCODE="" G C1
. I '$$VAL(FILE,.RCODE) W !!,"Code: "_RCODE_" not found, Please reenter...",! S X="",RCODE="" G C1
. S RET("CARC")=RCODE
;
I RCLIST="R" D
.; if invalid range/list of codes return here
C2 . ;
. S DIR("A")="Enter a List or Range of CARCs",DIR(0)="F^1:200"
. S DIR("?")="Codes can be entered as: 1,2,4:15,A1-B6"
. S DIR("?",1)="Please enter a list or range of CARC Codes, use a comma between elements"
. S DIR("?",2)="and a colon ':' or '-' to delimit ranges of codes."
. S DIR("??")="^D LIST^RCDPCRR(345)"
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!(Y="") S RCSTOP=1 Q
. S RCODE=$$UP(X) I '$$VAL(FILE,.RCODE) W !!,"Code: "_RCODE_" not found. Please try again...",! S X="",RCODE="" G C2
. S RET("CARC")=RCODE
Q
;
LIST(FILE) ; Used for "??" to list the CARC or RARC code and 60 characters of the description
N I,C,QQ,Y,DTOUT,DUOUT,CNT,DIR,RC1,RCZ S CNT=0,C=IOSL-3,QQ=0
S JJ=0 F I=1:1 S JJ=$O(^RC(FILE,JJ)) Q:(+JJ=0)!(QQ=1) D
. S RCZ=^RC(FILE,JJ,0),RC1=$P($G(^RC(FILE,JJ,1,1,0)),".")
. S CNT=CNT+1 W !,$S($P(RCZ,U,3)&($P(RCZ,U,3)'>DT):"*",1:" ")_$J($P(RCZ,U),4),?7,$E(RC1,1,60)
. I CNT#C=0 S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y="")!(Y="^") S QQ=1 Q
Q
GRARC(RET) ; Get RARC data elements for report
N RCLIST,RCODE,DTOUT,DUOUT,FILE
S FILE=346
S DIR("A")="Select a (R)ARC, Ra(N)ge of RARCs or (A)ll?: ",DIR(0)="SA^A:All RARCs;R:Single RARC;N:Range/List of RARCs"
S DIR("B")="All" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S RCSTOP=1 Q
S RCLIST=Y
I RCLIST="A" S RET("RARC")="ALL" Q
;
I RCLIST="R" D Q
. ; if invalid code return here
G1 . ;
. S DIR("A")="Enter a RARC code",DIR(0)="F^1:200"
. S DIR("?")="Only a single codes can be entered as: A1"
. S DIR("?",1)="Please enter one RARC for the report."
. S DIR("?",2)="The single validated code will be included in the report."
. S DIR("??")="^D LIST^RCDPCRR(346)"
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!(Y="") S RCSTOP=1 Q
. S RCODE=$$UP(X)
. I (RCODE[":"),(RCODE["-"),(RCODE[",") W !!,"Code: "_RCODE_" not found. Please try again...",! S X="",RCODE="" G G1
. I '$$VAL(FILE,.RCODE) W !!,"Code: "_RCODE_" not found, Please try again...",! S X="",RCODE="" G G1
. S RET("RARC")=RCODE
;
I RCLIST="N" D
.; if invalid range of codes return here
G2 . ;
. S DIR("A")="Enter a List or Range of RARC codes",DIR(0)="F^1:200"
. S DIR("?")="Codes can be entered as: M1,M16:M20,M40-M45"
. S DIR("?",1)="Please enter a list or range of RARC Codes, use a comma ',' between elements"
. S DIR("?",2)="and a colon ':' or '-' to delimit ranges of codes."
. S DIR("??")="^D LIST^RCDPCRR(346)"
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT)!(Y="") S RCSTOP=1 Q
. S RCODE=$$UP(X)
. I '$$VAL(FILE,.RCODE) W !!,"Code: "_RCODE_" not found, Please try again...",! S X="",RCODE="" G G2
. S RET("RARC")=RCODE
Q
;
GCD(RET,CS) ; Get CARC and/or RARC data elements for Quick Search report
N RCLIST,RCODE,DTOUT,DUOUT,FILE,CK0,CK1,CD,EX
S FILE(0)=345,FILE(1)=346
GC1 ;if invalid code return here
S DIR("A")="Enter a CARC or RARC Code",DIR(0)="F^1:200"
S DIR("?")="Enter codes as a single code or list of codes as: 1 or 1,M1"
S DIR("?",1)="Please enter CARCs and/or RARCs for the report."
S DIR("?",2)="The validated code(s) will be included in the report."
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S RET="EXIT",RCSTOP=1 Q
S RCLIST=$$UP(X)
I (RCLIST[":")!(RCLIST["-") W !!,"Code: "_RCLIST_" not found. Please try again...",! S X="",RCLIST="" G GC1
; Check each code
S EX=0,CD="" K RET("CARC"),RET("RARC")
F I=1:1 S CD=$P(RCLIST,",",I) Q:CD="" D I EX'=0 W !!,"Code: "_CD_" not found. Please try again...",! S X="",RCLIST="" G GC1
. S CK0=$$VAL(FILE(0),.CD)
. S CK1=$$VAL(FILE(1),.CD)
. ; If both the CARC and RARC returns an invalid set the exit code and quit the checks
. I 'CK0,'CK1 S EX=1 Q ; Abort if we don't have a valid code
. ; Set the appropriate array either CARC or RARC.
. S:CK0 RET("CARC")=$S($G(RET("CARC"))]"":$G(RET("CARC"))_","_CD,1:CD)
. S:CK1 RET("RARC")=$S($G(RET("RARC"))]"":$G(RET("RARC"))_","_CD,1:CD)
; So are we processing just CARC, just RARC or both CARC and RARC
S CS=$S(($G(RET("CARC"))]"")&($G(RET("CARC"))=""):"C",($G(RET("CARC"))="")&($G(RET("CARC"))]""):"R",1:"B")
Q
;
DATE(X,F) ; date in external format See XLFDT1 for codes
Q $$DATE^RCDPRU(X,$G(F))
;
HDR2(ST,RT,DT) ; Report header
N LINE,REP
S LINE=$S(ST="A":"ACTIVE",ST="I":"INACTIVE",1:"ACTIVE AND INACTIVE")
S REP=$S(RT="C":"CARC",RT="R":"RARC",1:"CARC/RARC")
S LINE=LINE_" "_REP_" DATA AS OF REPORT DATE: "_$$DATE(DT)
Q LINE
;
HDR3() ; Fuction to return report column header lines, just used within this routine.
N LINE
S LINE="CODE START DATE STOP DATE DATE MODIFIED CARC/RARC LAST VISTA UPDATE"_$C(10,13)
S LINE=LINE_" CODE DESCRIPTION"
Q LINE
;
HDRP(Z,X,Z1) ; Print Header (Z=String, X=1 (line feed) X=0 (no LF), Z1 (page number right justified)
I X=1 W !
W ?(IOM-$L(Z)\2),Z W:$G(Z1)]"" ?(IOM-$L(Z1)),Z1
Q
NEWPG(RCPG,RCNEW,RCSL) ; Check for new page needed, output header
; RCPG = Page number passwd by referece
; RCNEW = 1 to force new page
; RCSL = page length passed by reference
; Function returns 1 if user chooses to stop output
N RCSTOP S RCSTOP=0
I RCNEW!'RCPG!(($Y+5)>IOSL) D
. D:RCPG ASK^RCDPRU(.RCSTOP) I RCSTOP Q
. S RCPG=RCPG+1 W @IOF
. I $G(QS)=1 D HDRP("EDI LOCKBOX CARC/RARC QUICK SEARCH",1,"Page: "_RCPG)
. E D HDRP("EDI LOCKBOX CARC/RARC TABLE DATA REPORT",1,"Page: "_RCPG)
. D HDRP("REPORT RUN DATE: "_RCNOW,1)
. D:+$G(QS)'=1 HDRP($$HDR2(RCSTAT,RCDET,RCDT1),1) W !!
. W $$HDR3(),!
. W RCHR,! S RCSL=7
Q RCSTOP
;
VAL(XF,CODE) ; Validate a range or list of CARC (345), RARC (346) or PLB (345.1) Codes
; If invalid code is found VAILD = 0 and CODE will contain the offending codes
Q $$VAL^RCDPRU(XF,.CODE)
;
UP(TEXT) ; Translate text to upper case
Q $$UP^XLFSTR(TEXT)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPCRR 16193 printed Sep 23, 2025@19:20 Page 2
RCDPCRR ;ALB/TJB - CARC/RARC DATA TABLE REPORT ;11/03/14 1:00pm
+1 ;;4.5;Accounts Receivable;**303**;Mar 20, 1995;Build 84
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ; PRCA*4.5*303 - CARC/RARC DATA Table report
+5 ;
+6 ; DESCRIPTION : The following generates a report that displays selected or all
+7 ; CARC or RARC Codes from the Files 345 (CARC) or 346 (RARC).
+8 ; several filters may be used to limit the codes displayed:
+9 ; * CARCs only, RARCs only or Both - default is both.
+10 ; * Display Active, Inactive or Both - default is active
+11 ; * Report Date - default today
+12 ; * Output to excel (Yes/No) - default is no
+13 ;
+14 ; INPUTS : The user is prompted for the following:
+15 ; CARC/RARC/Both Codes
+16 ; Prompt for codes to display
+17 ; Active/Inactive
+18 ; Report Date
+19 ; Output report to Excel
+20 ;
EN ; Entry point for Report
+1 NEW DUOUT,DTOUT,DIR,X,Y,Z,I,JJ,KK,DL,CD,EXLN,IX,RCDT1,RCDET,ZTRTN,ZTSK,ZTDESC,ZTSAVE,ZTSTOP,%ZIS,POP
+2 NEW RCJOB,RCCD,RCRD,RCNOW,RCODE,RCSTAT,RCPG,RCHR,RCDISP,IDX,TY,FILE,IEN,ZN,RCQUIT,XCNT
+3 SET RCQUIT=0
+4 ;
+5 ; Quick Search
+6 ; Go to regular report
if $GET(QS)'=1
GOTO R1
+7 ;
+8 DO GCD(.RCCD,.RCDET)
+9 IF $GET(RCCD)="EXIT"
GOTO ARCQ
+10 SET RCDISP=0
SET RCSTAT="B"
SET RCDT1=$$DT^XLFDT
KILL ^TMP("RC_CARC_RARC_TABLE",$JOB)
+11 DO GETCODES($GET(RCCD("CARC")),$GET(RCCD("RARC")),RCSTAT,RCDT1,$NAME(^TMP("RC_CARC_RARC_TABLE",$JOB)))
+12 ;,IOSL=40
SET RCODE="CARC^RARC"
SET RCNOW=$$NOW^RCDPRU()
SET RCPG=0
SET $PIECE(RCHR,"=",IOM)=""
+13 GOTO REPORT
+14 ;
R1 ;
+1 SET RCODE=""
+2 SET DIR("A")="Select (N)o CARCs or (A)ll CARCs?: "
SET DIR(0)="SA^N:No CARCs to Include;A:All CARCs Included"
+3 SET DIR("B")="ALL"
DO ^DIR
KILL DIR
+4 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO ARCQ
+5 SET RCDET=$$UP(Y)
+6 IF RCDET="A"
SET RCCD("CARC")="ALL"
SET RCODE="CARC"
+7 ;
+8 SET DIR("A")="Select (N)o RARCs or (A)ll RARCs?: "
SET DIR(0)="SA^N:No RARCs to Include;A:All RARCs Included"
+9 SET DIR("B")="ALL"
DO ^DIR
KILL DIR
+10 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO ARCQ
+11 SET RCDET=$$UP(Y)
+12 IF RCDET="A"
SET RCRD("RARC")="ALL"
SET RCODE=$SELECT(RCODE'="":RCODE_"^RARC",1:"RARC")
+13 ;
+14 IF RCODE']""
WRITE !!,"Error: No Codes selected for display...",!,"Please select either CARC and/or RARC to include on report",!
GOTO R1
+15 ;
+16 SET DIR("A")="Include (A)ctive codes, (I)nactive codes or (B)oth?: "
SET DIR(0)="SA^A:ACTIVE Codes;I:INACTIVE Codes;B:BOTH ACTIVE/INACTIVE Codes"
+17 SET DIR("?")="Active/Inactive will be based on the date selected."
+18 SET DIR("?",1)="Please indicate Active/Inactive/Both for codes included on the report."
+19 SET DIR("?",2)="Active and Inactive codes will be determined by the date of the report."
+20 SET DIR("B")="ACTIVE"
DO ^DIR
KILL DIR
+21 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO ARCQ
+22 SET RCSTAT=$$UP(Y)
+23 ;
DT1 ; Check the date
+1 SET DIR("?")="Enter Date for the report"
+2 SET DIR(0)="DAO^:"_DT_":APE"
SET DIR("B")="T"
SET DIR("A")="Report Date: "
DO ^DIR
KILL DIR
+3 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
GOTO ARCQ
+4 SET RCDT1=Y
+5 IF RCDT1<2950102
WRITE !,"Invalid date entered, no records for report.",!,"Please select a date after 1/1/1995.",!
GOTO DT1
+6 ;
+7 WRITE !
+8 ; Send output to excel. (Removed excel output because description would be truncated)
+9 SET RCDISP=0
+10 ;S RCDISP=$$DISPTY^RCDPRU()
+11 ;D:RCDISP INFO^RCDPRU
+12 ;
+13 SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+14 IF $DATA(IO("Q"))
Begin DoDot:1
+15 SET ZTRTN="ENQ^RCDPCRR"
SET ZTDESC="AR - CARC & RARC DATA REPORT"
SET ZTSAVE("*")=""
+16 DO ^%ZTLOAD
+17 WRITE !!,$SELECT($DATA(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
+18 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
QUIT
+19 USE IO
+20 ;
ENQ ; Return here for queued print
+1 SET RCNOW=$$NOW^RCDPRU()
SET RCPG=0
SET $PIECE(RCHR,"=",IOM)=""
+2 ;
+3 KILL ^TMP("RC_CARC_RARC_TABLE",$JOB)
+4 DO GETCODES($GET(RCCD("CARC")),$GET(RCRD("RARC")),RCSTAT,RCDT1,$NAME(^TMP("RC_CARC_RARC_TABLE",$JOB)))
+5 ;
REPORT ;
+1 ; Report
+2 IF RCDISP=0
Begin DoDot:1
+3 SET RCPG=1
WRITE @IOF
+4 IF $GET(QS)=1
DO HDRP("EDI LOCKBOX CARC/RARC QUICK SEARCH",1,"Page: "_RCPG)
+5 IF '$TEST
DO HDRP("EDI LOCKBOX CARC/RARC TABLE DATA REPORT",1,"Page: "_RCPG)
+6 DO HDRP("REPORT RUN DATE: "_RCNOW,1)
+7 if +$GET(QS)'=1
DO HDRP($$HDR2(RCSTAT,RCDET,RCDT1),1)
WRITE !!
+8 WRITE $$HDR3(),!
+9 WRITE RCHR,!
SET RCSL=8
End DoDot:1
+10 IF '$TEST
WRITE "CODE^START^STOP^MODIFIED^VDATE^TYPE^DESCRIPTION^NOTES",!
+11 SET IDX=RCODE
+12 FOR JJ=1:1
SET TY=$PIECE(IDX,U,JJ)
SET CD=""
if TY=""!RCQUIT
QUIT
SET FILE=$SELECT(TY="RARC":346,1:345)
FOR
SET CD=$ORDER(^TMP("RC_CARC_RARC_TABLE",$JOB,TY,CD))
if CD=""!RCQUIT
QUIT
Begin DoDot:1
+13 SET IEN=""
SET IEN=$ORDER(^TMP("RC_CARC_RARC_TABLE",$JOB,TY,CD,IEN))
SET ZN=$GET(^TMP("RC_CARC_RARC_TABLE",$JOB,TY,CD,IEN))
+14 KILL RCDAT,RCERR
+15 ; Get Description (4) and Notes (5) fields
DO GETS^DIQ(FILE,IEN_",","4;5","","RCDAT","RCERR")
+16 ; Output Excel
IF RCDISP
Begin DoDot:2
+17 SET EXLN=$PIECE(ZN,U,1)_U_$$DATE($PIECE(ZN,U,2))
+18 SET EXLN=EXLN_U_$SELECT($PIECE(ZN,U,3)="":"",1:$$DATE($PIECE(ZN,U,3)))_U_$SELECT($PIECE(ZN,U,4)="":"",1:$$DATE($PIECE(ZN,U,4)))_U_$SELECT($PIECE(ZN,U,5)="":"",1:$$DATE($PIECE($PIECE(ZN,U,5),".",1)))_U_TY
+19 ; Collect Discription into a single variable for output
+20 SET KK=""
SET DL=""
+21 FOR
SET KK=$ORDER(RCDAT(FILE,IEN_",",4,KK))
if KK=""
QUIT
SET DL=DL_$GET(RCDAT(FILE,IEN_",",4,KK))
+22 SET EXLN=EXLN_U_DL
+23 ;Add notes
+24 SET EXLN=EXLN_U_$GET(RCDAT(FILE,IEN_",",5))
+25 WRITE EXLN,!
End DoDot:2
+26 ; Output to the screen
IF '$TEST
Begin DoDot:2
+27 WRITE ?(4-$LENGTH($PIECE(ZN,U,1))),$PIECE(ZN,U,1),?8,$$DATE($PIECE(ZN,U,2))
+28 if $PIECE(ZN,U,3)'=""
WRITE ?21,$$DATE($PIECE(ZN,U,3))
if $PIECE(ZN,U,4)'=""
WRITE ?35,$$DATE($PIECE(ZN,U,4))
WRITE ?51,TY
if $PIECE(ZN,U,5)'=""
WRITE ?64,$$DATE($PIECE($PIECE(ZN,U,5),".",1))
WRITE !
SET RCSL=RCSL+1
+29 IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL)
if RCQUIT
GOTO ARCQ
+30 ;Accumulate the Word Processing Description Field
+31 SET IX=""
SET XCNT=0
KILL ^UTILITY($JOB,"W")
+32 FOR
SET IX=$ORDER(RCDAT(FILE,IEN_",",4,IX))
if IX=""
QUIT
SET X=RCDAT(FILE,IEN_",",4,IX)
SET DIWL=6
SET DIWR=IOM
SET DIWF="W"
DO ^DIWP
SET RCSL=RCSL+1
IF RCSL>=(IOSL-2)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL)
if RCQUIT
GOTO ARCQ
+33 DO ^DIWW
SET RCSL=RCSL+1
+34 IF RCSL>=(IOSL-3)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL)
if RCQUIT
GOTO ARCQ
+35 ;Print the Notes Field
+36 IF $GET(RCDAT(FILE,IEN_",",5))'=""
KILL ^UTILITY($JOB,"W")
SET X="NOTES: "_RCDAT(FILE,IEN_",",5)
SET DIWL=6
SET DIWR=IOM
SET DIWF=""
DO ^DIWP
DO ^DIWW
SET RCSL=RCSL+1
+37 WRITE !
SET RCSL=RCSL+1
+38 IF RCSL>=(IOSL-3)
SET RCQUIT=$$NEWPG(.RCPG,0,.RCSL)
if RCQUIT
GOTO ARCQ
End DoDot:2
End DoDot:1
+39 ;
+40 if 'RCQUIT
DO ASK^RCDPRU(.RCSTOP)
ARCQ ; Clean up and quit
+1 KILL DHDR,RCEXCEL,RCLIST,RCODE,DIWL,DIWR,DIWF,IX,DATA,ERROR,QS
+2 KILL ^TMP("RC_CARC_RARC_TABLE",$JOB)
+3 QUIT
+4 ;
GETCODES(CARC,RARC,STAT,RDT,ARRAY,DESC) ;
+1 ; CARC = CARC data to retrieve
+2 ; RARC = RARC data to retrieve
+3 ; CARC and RARC can be a single code, a list of codes, range or combination.
+4 ; STAT = Retrieve Active, Inactive or Both codes
+5 ; RDT = Report date (used to determine Active/Inactive status)
+6 ; ARRAY = Stuff the data into ARRAY passed for as a string for indirection
+7 ; DESC (optional) = Add description to ARRAY, second ^ is length, if
+8 ; undefined or less than 10 characters description
+9 ; length will be 10 characters, maximum is 250 characters
+10 IF $GET(DESC)=""
SET DESC=0
+11 IF CARC]""
DO ELEM("CARC",345,CARC,STAT,RDT,.ARRAY,DESC)
+12 IF RARC]""
DO ELEM("RARC",346,RARC,STAT,RDT,.ARRAY,DESC)
+13 QUIT
+14 ;
ELEM(TYPE,FILE,DAT,STAT,RDT,ARRAY,DESC) ;
+1 NEW I,OKAY,R1,R2,RX,RY,RZ,O1,ELEM,DATA,START,STOP,DL,RCZT
SET DL=""
+2 IF $GET(DESC)'=0
SET DL=$PIECE(DESC,U,2)
if +$GET(DL)<10
SET DL=10
if $GET(DL)>250
SET DL=250
+3 IF DAT="ALL"
SET R1=$ORDER(^RC(FILE,"B",""))
SET R2=$ORDER(^RC(FILE,"B",""),-1)
SET DAT=R1_":"_R2
+4 FOR I=1:1
SET ELEM=$PIECE(DAT,",",I)
if ELEM=""
QUIT
Begin DoDot:1
+5 ; Range
IF ELEM[":"
Begin DoDot:2
+6 SET R1=$PIECE(ELEM,":",1)
SET R2=$PIECE(ELEM,":",2)
SET RX=$ORDER(^RC(FILE,"B",R1),-1)
+7 FOR
SET RX=$ORDER(^RC(FILE,"B",RX))
if (RX]]R2)!(RX="")
QUIT
Begin DoDot:3
+8 SET O1=$ORDER(^RC(FILE,"B",RX,""))
SET DATA=^RC(FILE,O1,0)
SET START=$PIECE(DATA,U,2)
SET STOP=$PIECE(DATA,U,3)
+9 if DL'=""
Begin DoDot:4
+10 ; Get description if wanted
+11 KILL RCZT
SET RY=$$GET1^DIQ(FILE,O1_",",4,"","RCZT")
SET RY=""
SET RZ=""
FOR
SET RZ=$ORDER(RCZT(RZ))
if RZ=""
QUIT
SET RY=RY_RCZT(RZ)_" "
+12 SET RY=$EXTRACT(RY,1,DL)
End DoDot:4
+13 ;S OKAY=$S(STAT="B":1,STAT="I":$S(STOP="":0,STOP<=RDT:1,1:0),STAT="A":$S(STOP="":1,STOP>RDT:1,STOP<=RDT:0,1:0))
+14 SET OKAY=$$STAT(STAT,RDT,STOP,START)
+15 if OKAY
SET @ARRAY@(TYPE,RX,O1)=DATA
if OKAY&(DL'="")
SET @ARRAY@(TYPE,RX,O1)=@ARRAY@(TYPE,RX,O1)_U_RY
End DoDot:3
End DoDot:2
+16 IF '$TEST
Begin DoDot:2
+17 ;Add an individual code
+18 SET O1=$ORDER(^RC(FILE,"B",ELEM,""))
SET DATA=^RC(FILE,O1,0)
SET START=$PIECE(DATA,U,2)
SET STOP=$PIECE(DATA,U,3)
+19 if DL'=""
Begin DoDot:3
+20 ; Get description if wanted
+21 KILL RCZT
SET RY=$$GET1^DIQ(FILE,O1_",",4,"","RCZT")
SET RY=""
SET RZ=""
FOR
SET RZ=$ORDER(RCZT(RZ))
if RZ=""
QUIT
SET RY=RY_RCZT(RZ)_" "
+22 SET RY=$EXTRACT(RY,1,DL)
End DoDot:3
+23 ;S OKAY=$S(STAT="B":1,STAT="I":$S(STOP="":0,STOP<=RDT:1,1:0),STAT="A":$S(STOP="":1,STOP>RDT:1,STOP<=RDT:0,1:0))
+24 SET OKAY=$$STAT(STAT,RDT,STOP,START)
+25 if OKAY
SET @ARRAY@(TYPE,ELEM,O1)=DATA
if OKAY&(DL'="")
SET @ARRAY@(TYPE,ELEM,O1)=@ARRAY@(TYPE,ELEM,O1)_U_RY
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
STAT(INC,ZDT,SP,ST) ; Determine if this code should be included in report
+1 ; INC = Active, Inactive, Both; ZDT = Date of report ; ST = Start date of code ; SP = Stop Date of code
+2 NEW RET
SET RET=0
+3 ; Both active and inactive and start date before report date
IF $GET(INC)="B"
if ($GET(ZDT)>$GET(ST))
SET RET=1
QUIT RET
+4 ; Inactive codes
IF $GET(INC)="I"
SET RET=0
Begin DoDot:1
+5 ; No stop date can't be inactive
IF $GET(SP)=""
SET RET=0
QUIT
+6 ; Inactive, Stop before report and Start date before report date
IF ($GET(ZDT)>$GET(SP))
IF ($GET(ZDT)>$GET(ST))
SET RET=1
QUIT
End DoDot:1
QUIT RET
+7 IF $GET(INC)="A"
SET RET=0
Begin DoDot:1
+8 ; Active, Start date before report date and no stop date
IF $GET(ZDT)>$GET(ST)
IF ($GET(SP)="")
SET RET=1
QUIT
+9 ; Active, Start date before report date and stop date after report date
IF $GET(ZDT)>$GET(ST)
IF ($GET(SP)>$GET(ZDT))
SET RET=1
QUIT
End DoDot:1
QUIT RET
+10 ; Return do not include
QUIT 0
+11 ;
GCARC(RET) ; Get CARC data elements for report
+1 NEW RCLIST,RCODE,DTOUT,DUOUT,FILE
+2 SET FILE=345
+3 SET DIR("A")="Select (C)ARC, (R)ange of CARCs or (A)ll ?: "
SET DIR(0)="SA^A:All CARCs;C:Single CARC;R:Range/List of CARCs"
+4 SET DIR("B")="ALL"
DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCSTOP=1
QUIT
+6 SET RCLIST=Y
+7 IF RCLIST="A"
SET RET("CARC")="ALL"
QUIT
+8 IF RCLIST="C"
Begin DoDot:1
+9 ; if invalid code return here
C1 ;
+1 ;F^1:200"
SET DIR("A")="Enter a CARC code"
SET DIR(0)="P^345;EABZ"
+2 SET DIR("?")="Only a single codes can be entered as: A1"
+3 SET DIR("?",1)="Please enter one CARC code for the report."
+4 SET DIR("?",2)="The single validated code will be included in the report."
+5 SET DIR("??")="^D LIST^RCDPCRR(345)"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCSTOP=1
QUIT
+8 SET RCODE=$$UP(X)
+9 IF (RCODE[":")
IF (RCODE["-")
IF (RCODE[",")
WRITE !!,"Code: "_RCODE_" not found. Please try again...",!
SET X=""
SET RCODE=""
GOTO C1
+10 IF '$$VAL(FILE,.RCODE)
WRITE !!,"Code: "_RCODE_" not found, Please reenter...",!
SET X=""
SET RCODE=""
GOTO C1
+11 SET RET("CARC")=RCODE
End DoDot:1
QUIT
+12 ;
+13 IF RCLIST="R"
Begin DoDot:1
+14 ; if invalid range/list of codes return here
C2 ;
+1 SET DIR("A")="Enter a List or Range of CARCs"
SET DIR(0)="F^1:200"
+2 SET DIR("?")="Codes can be entered as: 1,2,4:15,A1-B6"
+3 SET DIR("?",1)="Please enter a list or range of CARC Codes, use a comma between elements"
+4 SET DIR("?",2)="and a colon ':' or '-' to delimit ranges of codes."
+5 SET DIR("??")="^D LIST^RCDPCRR(345)"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCSTOP=1
QUIT
+8 SET RCODE=$$UP(X)
IF '$$VAL(FILE,.RCODE)
WRITE !!,"Code: "_RCODE_" not found. Please try again...",!
SET X=""
SET RCODE=""
GOTO C2
+9 SET RET("CARC")=RCODE
End DoDot:1
+10 QUIT
+11 ;
LIST(FILE) ; Used for "??" to list the CARC or RARC code and 60 characters of the description
+1 NEW I,C,QQ,Y,DTOUT,DUOUT,CNT,DIR,RC1,RCZ
SET CNT=0
SET C=IOSL-3
SET QQ=0
+2 SET JJ=0
FOR I=1:1
SET JJ=$ORDER(^RC(FILE,JJ))
if (+JJ=0)!(QQ=1)
QUIT
Begin DoDot:1
+3 SET RCZ=^RC(FILE,JJ,0)
SET RC1=$PIECE($GET(^RC(FILE,JJ,1,1,0)),".")
+4 SET CNT=CNT+1
WRITE !,$SELECT($PIECE(RCZ,U,3)&($PIECE(RCZ,U,3)'>DT):"*",1:" ")_$JUSTIFY($PIECE(RCZ,U),4),?7,$EXTRACT(RC1,1,60)
+5 IF CNT#C=0
SET DIR(0)="E"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")!(Y="^")
SET QQ=1
QUIT
End DoDot:1
+6 QUIT
GRARC(RET) ; Get RARC data elements for report
+1 NEW RCLIST,RCODE,DTOUT,DUOUT,FILE
+2 SET FILE=346
+3 SET DIR("A")="Select a (R)ARC, Ra(N)ge of RARCs or (A)ll?: "
SET DIR(0)="SA^A:All RARCs;R:Single RARC;N:Range/List of RARCs"
+4 SET DIR("B")="All"
DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCSTOP=1
QUIT
+6 SET RCLIST=Y
+7 IF RCLIST="A"
SET RET("RARC")="ALL"
QUIT
+8 ;
+9 IF RCLIST="R"
Begin DoDot:1
+10 ; if invalid code return here
G1 ;
+1 SET DIR("A")="Enter a RARC code"
SET DIR(0)="F^1:200"
+2 SET DIR("?")="Only a single codes can be entered as: A1"
+3 SET DIR("?",1)="Please enter one RARC for the report."
+4 SET DIR("?",2)="The single validated code will be included in the report."
+5 SET DIR("??")="^D LIST^RCDPCRR(346)"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCSTOP=1
QUIT
+8 SET RCODE=$$UP(X)
+9 IF (RCODE[":")
IF (RCODE["-")
IF (RCODE[",")
WRITE !!,"Code: "_RCODE_" not found. Please try again...",!
SET X=""
SET RCODE=""
GOTO G1
+10 IF '$$VAL(FILE,.RCODE)
WRITE !!,"Code: "_RCODE_" not found, Please try again...",!
SET X=""
SET RCODE=""
GOTO G1
+11 SET RET("RARC")=RCODE
End DoDot:1
QUIT
+12 ;
+13 IF RCLIST="N"
Begin DoDot:1
+14 ; if invalid range of codes return here
G2 ;
+1 SET DIR("A")="Enter a List or Range of RARC codes"
SET DIR(0)="F^1:200"
+2 SET DIR("?")="Codes can be entered as: M1,M16:M20,M40-M45"
+3 SET DIR("?",1)="Please enter a list or range of RARC Codes, use a comma ',' between elements"
+4 SET DIR("?",2)="and a colon ':' or '-' to delimit ranges of codes."
+5 SET DIR("??")="^D LIST^RCDPCRR(346)"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RCSTOP=1
QUIT
+8 SET RCODE=$$UP(X)
+9 IF '$$VAL(FILE,.RCODE)
WRITE !!,"Code: "_RCODE_" not found, Please try again...",!
SET X=""
SET RCODE=""
GOTO G2
+10 SET RET("RARC")=RCODE
End DoDot:1
+11 QUIT
+12 ;
GCD(RET,CS) ; Get CARC and/or RARC data elements for Quick Search report
+1 NEW RCLIST,RCODE,DTOUT,DUOUT,FILE,CK0,CK1,CD,EX
+2 SET FILE(0)=345
SET FILE(1)=346
GC1 ;if invalid code return here
+1 SET DIR("A")="Enter a CARC or RARC Code"
SET DIR(0)="F^1:200"
+2 SET DIR("?")="Enter codes as a single code or list of codes as: 1 or 1,M1"
+3 SET DIR("?",1)="Please enter CARCs and/or RARCs for the report."
+4 SET DIR("?",2)="The validated code(s) will be included in the report."
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET RET="EXIT"
SET RCSTOP=1
QUIT
+7 SET RCLIST=$$UP(X)
+8 IF (RCLIST[":")!(RCLIST["-")
WRITE !!,"Code: "_RCLIST_" not found. Please try again...",!
SET X=""
SET RCLIST=""
GOTO GC1
+9 ; Check each code
+10 SET EX=0
SET CD=""
KILL RET("CARC"),RET("RARC")
+11 FOR I=1:1
SET CD=$PIECE(RCLIST,",",I)
if CD=""
QUIT
Begin DoDot:1
+12 SET CK0=$$VAL(FILE(0),.CD)
+13 SET CK1=$$VAL(FILE(1),.CD)
+14 ; If both the CARC and RARC returns an invalid set the exit code and quit the checks
+15 ; Abort if we don't have a valid code
IF 'CK0
IF 'CK1
SET EX=1
QUIT
+16 ; Set the appropriate array either CARC or RARC.
+17 if CK0
SET RET("CARC")=$SELECT($GET(RET("CARC"))]"":$GET(RET("CARC"))_","_CD,1:CD)
+18 if CK1
SET RET("RARC")=$SELECT($GET(RET("RARC"))]"":$GET(RET("RARC"))_","_CD,1:CD)
End DoDot:1
IF EX'=0
WRITE !!,"Code: "_CD_" not found. Please try again...",!
SET X=""
SET RCLIST=""
GOTO GC1
+19 ; So are we processing just CARC, just RARC or both CARC and RARC
+20 SET CS=$SELECT(($GET(RET("CARC"))]"")&($GET(RET("CARC"))=""):"C",($GET(RET("CARC"))="")&($GET(RET("CARC"))]""):"R",1:"B")
+21 QUIT
+22 ;
DATE(X,F) ; date in external format See XLFDT1 for codes
+1 QUIT $$DATE^RCDPRU(X,$GET(F))
+2 ;
HDR2(ST,RT,DT) ; Report header
+1 NEW LINE,REP
+2 SET LINE=$SELECT(ST="A":"ACTIVE",ST="I":"INACTIVE",1:"ACTIVE AND INACTIVE")
+3 SET REP=$SELECT(RT="C":"CARC",RT="R":"RARC",1:"CARC/RARC")
+4 SET LINE=LINE_" "_REP_" DATA AS OF REPORT DATE: "_$$DATE(DT)
+5 QUIT LINE
+6 ;
HDR3() ; Fuction to return report column header lines, just used within this routine.
+1 NEW LINE
+2 SET LINE="CODE START DATE STOP DATE DATE MODIFIED CARC/RARC LAST VISTA UPDATE"_$CHAR(10,13)
+3 SET LINE=LINE_" CODE DESCRIPTION"
+4 QUIT LINE
+5 ;
HDRP(Z,X,Z1) ; Print Header (Z=String, X=1 (line feed) X=0 (no LF), Z1 (page number right justified)
+1 IF X=1
WRITE !
+2 WRITE ?(IOM-$LENGTH(Z)\2),Z
if $GET(Z1)]""
WRITE ?(IOM-$LENGTH(Z1)),Z1
+3 QUIT
NEWPG(RCPG,RCNEW,RCSL) ; Check for new page needed, output header
+1 ; RCPG = Page number passwd by referece
+2 ; RCNEW = 1 to force new page
+3 ; RCSL = page length passed by reference
+4 ; Function returns 1 if user chooses to stop output
+5 NEW RCSTOP
SET RCSTOP=0
+6 IF RCNEW!'RCPG!(($Y+5)>IOSL)
Begin DoDot:1
+7 if RCPG
DO ASK^RCDPRU(.RCSTOP)
IF RCSTOP
QUIT
+8 SET RCPG=RCPG+1
WRITE @IOF
+9 IF $GET(QS)=1
DO HDRP("EDI LOCKBOX CARC/RARC QUICK SEARCH",1,"Page: "_RCPG)
+10 IF '$TEST
DO HDRP("EDI LOCKBOX CARC/RARC TABLE DATA REPORT",1,"Page: "_RCPG)
+11 DO HDRP("REPORT RUN DATE: "_RCNOW,1)
+12 if +$GET(QS)'=1
DO HDRP($$HDR2(RCSTAT,RCDET,RCDT1),1)
WRITE !!
+13 WRITE $$HDR3(),!
+14 WRITE RCHR,!
SET RCSL=7
End DoDot:1
+15 QUIT RCSTOP
+16 ;
VAL(XF,CODE) ; Validate a range or list of CARC (345), RARC (346) or PLB (345.1) Codes
+1 ; If invalid code is found VAILD = 0 and CODE will contain the offending codes
+2 QUIT $$VAL^RCDPRU(XF,.CODE)
+3 ;
UP(TEXT) ; Translate text to upper case
+1 QUIT $$UP^XLFSTR(TEXT)
+2 ;
