- 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 Jan 18, 2025@02:45:12 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 ;