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