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 Dec 13, 2024@01:48:43 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
