Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCTCSJS1

RCTCSJS1.m

Go to the documentation of this file.
  1. RCTCSJS1 ;ALBANY/LEG - RCTCS REFERRAL REJECTS SUPPORT RTN;02/19/14 3:21 PM
  1. V ;;4.5;Accounts Receivable;**301,324**;Mar 20, 1995;Build 2
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;Overflow Program for RCTCSJS, to process CS REJECT server messages from AITC
  1. ;
  1. ;Patch PRCA*4.5*324 Modify internal resolution of reject reason
  1. ; display on profile view of bills
  1. ;
  1. ;Variables
  1. ; Input
  1. ; XMZ - (r) MailMan internal message number (IEN)
  1. ;
  1. ;;RCTCS REFERRAL REJECTS SUPPORT RTN
  1. ;===============================================================================
  1. Q ;
  1. PROFRJ(D0) ; displays Reject History on ACCOUNT RECEIVABLE PROFILE
  1. ;
  1. ; display summary
  1. K ARY N CDINT
  1. I '$D(^PRCA(430,D0,18)) Q ;
  1. W !,"CS REJECTS:" S D1=0
  1. ; collapses rejects records
  1. F S D1=$O(^PRCA(430,D0,18,D1)) Q:'D1 D ;
  1. . S RJREC=^PRCA(430,D0,18,D1,0)
  1. . S FDAT=$P(RJREC,"^") ; date
  1. . S SRCE=$P(RJREC,"^",2) ;source
  1. . S ERRCDS=$S($D(ARY(FDAT,SRCE)):ARY(FDAT,SRCE),1:",")
  1. . F PC=3:1:11 S ERRCD=$P(RJREC,"^",PC) Q:'$L(ERRCD) D ;
  1. . . S ARY(FDAT,SRCE,PC)=$P($G(^RC(348.5,ERRCD,0)),"^")_U_ERRCD,ERRCD=$P($G(^RC(348.5,ERRCD,0)),U) ;PRCA*4.5*324
  1. . . I ERRCDS'[(","_ERRCD_",") S ERRCDS=ERRCDS_ERRCD_","
  1. . S ARY(FDAT,SRCE)=ERRCDS
  1. . ;
  1. S FDAT=""
  1. F S FDAT=$O(ARY(FDAT)),SRCE="" Q:FDAT="" D ;
  1. . S Y=FDAT D DD^%DT S EXTDAT=Y ;
  1. . F S SRCE=$O(ARY(FDAT,SRCE)),CDIDX="" Q:SRCE="" D ;
  1. . . S ERRCDS=$TR($E(ARY(FDAT,SRCE),2,$L(ARY(FDAT,SRCE))-1),",","-")
  1. . . W ?12,"DATE: ",EXTDAT
  1. . . W ?33,"CODE(s): ",ERRCDS
  1. . . W ?71,"SOURCE: ",SRCE
  1. . W !
  1. ;
  1. ; display detail
  1. S FDAT="" N CDINT
  1. F S FDAT=$O(ARY(FDAT)),SRCE="" Q:FDAT="" D ;
  1. . S Y=FDAT D DD^%DT S EXTDAT=Y ;
  1. . F S SRCE=$O(ARY(FDAT,SRCE)),CDIDX="" Q:SRCE="" D ;
  1. . . W !!,"CS REJECT DATE:",?16,EXTDAT
  1. . . W ?34,"REJECT SOURCE: ",SRCE
  1. . . F RR=1:1 S CDIDX=$O(ARY(FDAT,SRCE,CDIDX)) Q:CDIDX="" D ;
  1. . . . W !?2,"REJECT REASON",RR,":"
  1. . . . W ?18,$P(ARY(FDAT,SRCE,CDIDX),U) S CDINT=$P(ARY(FDAT,SRCE,CDIDX),U,2) ; code ;PRCA*4.5*324
  1. . . . S (X,DESC)=$P(^RC(348.5,CDINT,0),"^",2)_"~"_$G(^RC(348.5,CDINT,1)) ;PRCA*4.5*324
  1. . . . I $L(DESC)<60 S ARY(FDAT,SRCE,CDIDX,1)=X
  1. . . . I $L(DESC)>59 D ;
  1. . . . . F LN=1:1 S STR=$E(X,1,59) D Q:'$L(X) ;
  1. . . . . . I $L(X)<60 S ARY(FDAT,SRCE,CDIDX,LN)=X,X="" Q
  1. . . . . . F L=$L(STR):-1:1 I $F(STR," ",L) S ARY(FDAT,SRCE,CDIDX,LN)=$E(X,1,L),X=$E(X,L+1,999) Q ;
  1. . . . F LN=1:1 Q:'$D(ARY(FDAT,SRCE,CDIDX,LN)) W:LN>1 ! W ?21,ARY(FDAT,SRCE,CDIDX,LN)
  1. . W !
  1. Q ;
  1. ;
  1. PROFRJA(D0,LN,OUTARY) ; sets into ^TMP Reject History on BILL PROFILE
  1. ;
  1. ; display summary
  1. S BLANK="",$P(BLANK," ",99)=""
  1. K ARY,OUTARY N CDINT
  1. I '$D(^PRCA(430,D0,18)) Q ;
  1. S LN=LN+1,OUTARY(LN,0)="CS REJECTS: " S D1=0
  1. ; collapses rejects records
  1. F S D1=$O(^PRCA(430,D0,18,D1)) Q:'D1 D ;
  1. . S RJREC=^PRCA(430,D0,18,D1,0)
  1. . S FDAT=$P(RJREC,"^") ; date
  1. . S SRCE=$P(RJREC,"^",2) ;source
  1. . S ERRCDS=$S($D(ARY(FDAT,SRCE)):ARY(FDAT,SRCE),1:",")
  1. . F PC=3:1:11 S ERRCD=$P(RJREC,"^",PC) Q:'$L(ERRCD) D ;
  1. . . S ARY(FDAT,SRCE,PC)=$P(^RC(348.5,ERRCD,0),"^")_U_ERRCD,ERRCD=$P($G(^RC(348.5,ERRCD,0)),U) ;PRCA*4.5*324
  1. . . I ERRCDS'[(","_ERRCD_",") S ERRCDS=ERRCDS_ERRCD_","
  1. . S ARY(FDAT,SRCE)=ERRCDS
  1. . ;
  1. S FDAT=""
  1. F S FDAT=$O(ARY(FDAT)),SRCE="" Q:FDAT="" D ;
  1. . S Y=FDAT D DD^%DT S EXTDAT=Y ;
  1. . F S SRCE=$O(ARY(FDAT,SRCE)),CDIDX="" Q:SRCE="" D ;
  1. . . S ERRCDS=$TR($E(ARY(FDAT,SRCE),2,$L(ARY(FDAT,SRCE))-1),",","-")
  1. . . S OUTARY(LN,0)=$E(OUTARY(LN,0)_BLANK,1,11)_"DATE: "_EXTDAT
  1. . . S OUTARY(LN,0)=$E(OUTARY(LN,0)_BLANK,1,32)_"CODE(s): "_ERRCDS
  1. . . S OUTARY(LN,0)=$E(OUTARY(LN,0)_BLANK,1,70)_"SOURCE: "_SRCE
  1. . S LN=LN+1,OUTARY(LN,0)=""
  1. ;
  1. ; display detail
  1. S FDAT=""
  1. F S FDAT=$O(ARY(FDAT)),SRCE="" Q:FDAT="" D ;
  1. . S Y=FDAT D DD^%DT S EXTDAT=Y ;
  1. . F S SRCE=$O(ARY(FDAT,SRCE)),CDIDX="" Q:SRCE="" D ;
  1. . . S LN=LN+1,(OUTARY(LN,0),OUTARY(LN+1,0))=""
  1. . . S LN=LN+1,OUTARY(LN,0)="CS REJECT DATE: "_EXTDAT
  1. . . S OUTARY(LN,0)=$E(OUTARY(LN,0)_BLANK,1,34)_"REJECT SOURCE: "_SRCE
  1. . . F RR=1:1 S CDIDX=$O(ARY(FDAT,SRCE,CDIDX)) Q:CDIDX="" D ;
  1. . . . S LN=LN+1,OUTARY(LN,0)=" REJECT REASON"_RR_": "
  1. . . . S OUTARY(LN,0)=OUTARY(LN,0)_$P(ARY(FDAT,SRCE,CDIDX),U)_" ",CDINT=$P(ARY(FDAT,SRCE,CDIDX),U,2) ; code ;PRCA*4.5*324
  1. . . . S (X,DESC)=$P(^RC(348.5,CDINT,0),"^",2)_"~"_$G(^RC(348.5,CDINT,1)) ;PRCA*4.5*324
  1. . . . I $L(DESC)<60 S ARY(FDAT,SRCE,CDIDX,1)=X
  1. . . . I $L(DESC)>59 D ;
  1. . . . . F LN2=1:1 S STR=$E(X,1,59) D Q:'$L(X) ;
  1. . . . . . I $L(X)<60 S ARY(FDAT,SRCE,CDIDX,LN2)=X,X="" Q
  1. . . . . . F L=$L(STR):-1:1 I $F(STR," ",L) S ARY(FDAT,SRCE,CDIDX,LN2)=$E(X,1,L),X=$E(X,L+1,999) Q ;
  1. . . . F LN2=1:1 Q:'$D(ARY(FDAT,SRCE,CDIDX,LN2)) D ;
  1. . . . . S:LN2>1 LN=LN+1,OUTARY(LN,0)=" "
  1. . . . . S OUTARY(LN,0)=OUTARY(LN,0)_ARY(FDAT,SRCE,CDIDX,LN2)
  1. . S LN=LN+1,OUTARY(LN,0)=""
  1. Q ;
  1. ;
  1. SENDBUL ;
  1. I '$G(BADQUE) D ;
  1. . S FROM=$G(H4DATE)_$G(ZBAT1),TO=$G(H4DATE)_$G(ZBAT2)
  1. . S BATMSG=" from MM Message"_$S(XMZ1=XMZ2:": "_XMZ1,1:"es: "_XMZ1_" to "_XMZ2)
  1. . S BATMSG=BATMSG_" from Batch"_$S(FROM=TO:": "_FROM,1:"es: "_FROM_" to "_TO)
  1. ;
  1. D NOW^%DTC,YX^%DTC
  1. S DTTM=$E(Y,5,6)_" "_$E(Y,1,3)_" "_$E(Y,11,12)_" "_$E(Y,14,18)_" "
  1. ;
  1. ; If there is no Source data or Errors, check and send Bulletin Data if available
  1. I $O(^XTMP("RCTCSJS",$J,"SRC",""))=""&($O(^XTMP("RCTCSJS",$J,"ERR",""))="") D BULERR
  1. ;
  1. F SOURCE="AITC","DMC","TREASURY" S SRC=$E(SOURCE) I $D(^XTMP("RCTCSJS",$J,"SRC",SRC)) D ;
  1. . D REJMSG
  1. . D ALPHA
  1. . S XMSUB="CS REJECTS ("_SOURCE_") ["_XMZ_"] "_DTTM_" "_CNTR_" lines"
  1. . D SEND
  1. . ;
  1. Q
  1. SENDERR ;
  1. I $D(^XTMP("RCTCSJS",$J,"ERR")) D ;
  1. . S SOURCES=""
  1. . F SRCPC=1:1:3 Q:$E(CSRCS,SRCPC)="" D
  1. . . S SOURCE=$P("???,AITC,DMC,TREASURY",",",$F("ADT",$E(CSRCS,SRCPC)))
  1. . . S SOURCES=SOURCES_","_$S(SOURCE="":"???",1:SOURCE)
  1. . S SOURCES=$E(SOURCES,2,999)
  1. . I '$L(SOURCES) S SOURCES="UNSPECIFIED SOURCE"
  1. . D ERRMSG
  1. . D ERRSFND
  1. . S XMSUB="CS ("_SOURCES_") REJECT RECORD ***ERRORS FOUND*** ["_XMZ_"] "_DTTM_" "_CNTR_" lines"
  1. . D SEND
  1. . ;
  1. Q ;
  1. CLEANUP ; This cleans up the ^XTMP global.
  1. ;K ^XTMP("RCTCSJS",$J)
  1. Q
  1. ;
  1. BULERR ; If there is Bulletin data, send email with error or note
  1. N HIT,CNT,CNTR
  1. S HIT=0,CNT=""
  1. I $O(^XTMP("RCTCSJS",$J,"BULTN",""))'="" S HIT=1
  1. I 'HIT Q
  1. S CNTR=$O(^XTMP("RCTCSJS",$J,"REC",$G(CNTR)),-1)
  1. S CNTR=CNTR+1
  1. S ^XTMP("RCTCSJS",$J,"REC",CNTR)="The following CS REJECTS transmissions have been processed"
  1. S CNTR=CNTR+1
  1. S ^XTMP("RCTCSJS",$J,"REC",CNTR)=BATMSG
  1. F S CNT=$O(^XTMP("RCTCSJS",$J,"BULTN",CNT)) Q:CNT="" S BULDAT=^(CNT) D
  1. . S CNTR=CNTR+1
  1. . S ^XTMP("RCTCSJS",$J,"REC",CNTR)=BULDAT
  1. S XMSUB="CS REJECTS ["_XMZ_"] "_DTTM_" "_CNTR_" lines"
  1. D SEND
  1. Q ; BULERR
  1. ;
  1. REJMSG ;Send list of rejected documents
  1. S ^XTMP("RCTCSJS",$J,"REC",1)="The following CS DEBT REFERRAL transmissions have been rejected"
  1. S ^XTMP("RCTCSJS",$J,"REC",2)=BATMSG
  1. S ^XTMP("RCTCSJS",$J,"REC",3)=""
  1. S ^XTMP("RCTCSJS",$J,"REC",4)="NAME SSN BILL NUMBER TYPE ACTN ERROR CODES"
  1. S ^XTMP("RCTCSJS",$J,"REC",5)=""
  1. S CNTR=5
  1. Q ; REJMSG
  1. ALPHA ; orders BULLETIN by SRC, Patient NAME, BILL NO. sequence
  1. S NAM=""
  1. F S NAM=$O(^XTMP("RCTCSJS",$J,"SRC",SRC,NAM)),SBILL="" Q:NAM="" D ;
  1. . F S SBILL=$O(^XTMP("RCTCSJS",$J,"SRC",SRC,NAM,SBILL)),BLTNCNT="" Q:SBILL="" D ;
  1. .. F S BLTNCNT=$O(^XTMP("RCTCSJS",$J,"SRC",SRC,NAM,SBILL,BLTNCNT)) Q:BLTNCNT="" D ;
  1. ... S BLTNREC=^XTMP("RCTCSJS",$J,"BULTN",BLTNCNT)
  1. ... S CNTR=CNTR+1,^XTMP("RCTCSJS",$J,"REC",CNTR)=BLTNREC
  1. Q ;
  1. ;
  1. ERRMSG ;Send list of ERRORS FOUND document
  1. S ^XTMP("RCTCSJS",$J,"REC",1)="The following **ERRORS** found in the ("_SOURCES_") CS DEBT REFERRAL Reject File"
  1. S ^XTMP("RCTCSJS",$J,"REC",2)=BATMSG
  1. S ^XTMP("RCTCSJS",$J,"REC",3)=""
  1. S ^XTMP("RCTCSJS",$J,"REC",4)=" # REC# TYPE OF ERROR ENCOUNTERED "
  1. S ^XTMP("RCTCSJS",$J,"REC",5)=""
  1. S CNTR=5
  1. Q ; ERRMSG
  1. ;
  1. ERRSFND ; places ERRORS FOUND records into BULLETIN sequence
  1. ; S ^XTMP("RCTCSJS",$J,"ERR",ERRCNT)=RECN_U_ERRDATA
  1. S ERRCNT=0
  1. F S ERRCNT=$O(^XTMP("RCTCSJS",$J,"ERR",ERRCNT)) Q:'ERRCNT D ;
  1. . S REC=^XTMP("RCTCSJS",$J,"ERR",ERRCNT)
  1. . S RECN=$P(REC,U),ERRDATA=$P(REC,U,2)
  1. . S ERRREC=$E($J(ERRCNT,4)_BLNKS,1,5)_$E(RECN_BLNKS,1,8)_$E(ERRDATA_BLNKS,1,66)
  1. . S CNTR=CNTR+1
  1. . S ^XTMP("RCTCSJS",$J,"REC",CNTR)=ERRREC
  1. Q ; ERRSFND
  1. ;
  1. SEND ;
  1. S XMY("G.TCSP")="",XMDUZ="AR PACKAGE",XMTEXT="^XTMP(""RCTCSJS"","_$J_",""REC"","
  1. D ^XMD
  1. Q