- RCTCSP3 ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
- ;;4.5;Accounts Receivable;**301,315,350**;Mar 20, 1995;Build 66
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- Q
- ;
- ENTER ;Entry point from the post initialization
- RCCSTUP I '$D(^XTMP("REJCDCONV")) D
- . D NOW^%DTC S RCCSTART=%
- . S ^XTMP("REJCDCONV","START COMPILE")=RCCSTART
- . S ^XTMP("REJCDCONV","STATUS")="RUNNING"
- . S ^XTMP("REJCDCONV",0)=$$FMADD^XLFDT(RCCSTART,730)_"^"_RCCSTART
- S RCCCMPLT=0 I $G(^XTMP("REJCDCONV","STATUS"))="COMPLETE" S RCCCMPLT=1
- AA N DEBTOR
- S DEBTOR=0
- F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
- .N X,RCDFN,DEMCS,DEBTOR0,DEBTOR1,DEBTOR7,BILL
- .S DEBTOR0=^RCD(340,DEBTOR,0),DEBTOR1=$G(^(1)),DEBTOR7=$G(^(7))
- .S RCDFN=+DEBTOR0
- .S DEMCS=$$DEM^RCTCSP1(RCDFN) Q:$E($P(DEMCS,U,3),1,5)="00000"
- .Q:+$P(DEMCS,U,4) ;deceased patient
- .S BILL=0
- .F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
- ..N B0,B6,B7,B14,CAT,TOTAL
- ..S B0=$G(^PRCA(430,BILL,0)),B6=$G(^(6)),B7=$G(^(7)),B14=$G(^(14))
- ..I 'RCCCMPLT,$D(^PRCA(430,BILL,18)) D REJCODE
- ..I $D(^PRCA(430,"TCSP",BILL)) Q ;no dpn for cs bills
- ..Q:'$P(B0,U,2) ;no category
- ..S CAT=$P($G(^PRCA(430.2,$P(B0,U,2),0)),U,7)
- ..Q:'CAT
- ..I ",4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,25,26,27,28,33,34,35,36,37,38,39,"[(","_CAT_",") Q ;1st party check
- ..I +$P(B14,U,1) Q ;bill referred to TOP
- ..S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
- ..I TOTAL'>0 Q ;total must be greater than zero
- ..I '$P(B0,U,8) Q ;if no current status
- ..I $P(B0,U,8)=23 Q ;quit if write-off
- ..I $P(B0,U,8)=26 Q ;quit if cancelled
- ..I $P(B0,U,8)=39 Q ;quit if cancellation
- ..I TOTAL<25 S $P(^PRCA(430,BILL,20),U,3,8)="1^^^^^" ;set dpn flag
- ..Q
- .Q
- I RCCCMPLT'=1 D
- . D NOW^%DTC S RCCEND=%
- . S ^XTMP("REJCDCONV","END REJ CODE CONV")=RCCEND
- . S ^XTMP("REJCDCONV","STATUS")="COMPLETE"
- Q
- ;
- DUEPROC ; called from rctcspd
- N TOTAL
- S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
- I TOTAL<25 Q ;no dpn record for bills less than $25
- I $P($G(DEBTOR3),U,10) Q ;check site delete flag null
- I +$P(B12,U,1) Q ;check date bill sent to dmc
- I $P(B6,U,4),($P(B6,U,5)="DOJ") Q ;bill referred to doj
- I $P(B0,U,8)'=16 Q ;status active
- I '$P(B6,U,3) Q ;must have a 3rd letter
- D RECDPN ;create a dpn record
- Q
- ;
- RECDPN ;
- N KNUM,NAME
- S REC="C"
- S REC=REC_$$RJZF(BILL,10)
- S REC=REC_$$TAXID(DEBTOR)
- S NAME=$$NAMEFF(+DEBTOR0),NAME=$P(NAME,U)
- S REC=REC_$$LJSF(NAME,30)
- S RCDFN=+DEBTOR0
- S ADDRCS=$$ADDR(RCDFN)
- S REC=REC_$$LJSF($P(ADDRCS,U,1),35)_$$LJSF($P(ADDRCS,U,2),35)_$$LJSF($P(ADDRCS,U,3),15)
- S REC=REC_$$LJSF($P(ADDRCS,U,8),20)
- S REC=REC_$$BLANK(5)
- S REC=REC_$$LJSF($P(ADDRCS,U,4),2)_$$LJSF($P(ADDRCS,U,5),9)
- S REC=REC_$$COUNTRY^RCTCSP1A($P(ADDRCS,U,7)) ;Changed routine due to SACC size issue PRCA*4.5*315
- S TOTAL=$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
- S REC=REC_$$BLANK(9)
- S REC=REC_$$DATE8(+$P(B6,U,21))
- S KNUM=$P($P(B0,U,1),"-",2)
- S REC=REC_$E(SITE,1,3)_$$LJSF(KNUM,7)
- S REC=REC_$$AMOUNT9(TOTAL)
- S REC=REC_$$LJSF($P(ADDRCS,U,9),10)
- S REC=REC_$S($P(ADDRCS,U,9)="":" ",$P(ADDRCS,U,9)="US":" ",1:"F")
- S REC=REC_$$BLANK(250-$L(REC))
- S $P(^PRCA(430,BILL,20),U,4)=DT ;set the dpn request date
- S $P(^PRCA(430,BILL,20),U,5,8)="^^^" ;clear the print date and error codes
- S ^XTMP("RCTCSPDN",$J,BILL,"DPN",1)=REC
- S ^XTMP("RCTCSPDN",$J,"BILL","DPN",BILL)=$$TAXID(DEBTOR)_"^"_+$E(REC,201,207)_"."_$E(REC,208,209) ;sends mailman message of documents sent to user
- Q
- ;
- COMPILED ;
- N RCMSG,BCNTR,REC,RECC,AMOUNT,AMOUNT,RCNTR,ACTION,SEQ,EOF
- S BCNTR=0,REC=0,RECC=0,AMOUNT=0,SEQ=0,EOF=0
- F S BCNTR=$O(^XTMP("RCTCSPDN",$J,BCNTR)) S:+BCNTR'>0 EOF=1 Q:+BCNTR'>0 D
- .I REC>120 D
- ..D TRAILERD
- ..D AITCMSGD
- ..S REC=0,RECC=0
- ..Q
- .S ACTION="DPN"
- .I REC=0 D HEADERD
- .S RCNTR=1 I $D(^XTMP("RCTCSPDN",$J,BCNTR,ACTION,RCNTR)) D
- ..S REC=REC+1
- ..S RECC=RECC+1 ;record count for 'c' records on trailer record
- ..S ^XTMP("RCTCSPDN",$J,SEQ,"BUILD",REC)=^XTMP("RCTCSPDN",$J,BCNTR,ACTION,RCNTR)_$C(126)
- ..S AMOUNT=AMOUNT+$E(^XTMP("RCTCSPDN",$J,BCNTR,ACTION,RCNTR),201,209)
- ..Q
- .Q
- D TRAILERD
- D AITCMSGD
- D USRMSGD
- Q
- ;
- AITCMSGD ;
- N XMY,XMDUZ,XMSUB,XMTEXT,SYSTYP
- S SYSTYP=$$PROD^XUPROD(1) ; PRCA*4.5*350
- Q:'$D(^XTMP("RCTCSPDN",$J))
- S CNTLID=$$JD()_$$RJZF(SEQ,4)
- S XMDUZ="AR PACKAGE"
- I SYSTYP S XMY("XXX@Q-TPL.DOMAIN.EXT")=""
- I 'SYSTYP S XMY("XXX@Q-TXL.DOMAIN.EXT")=""
- S XMY("G.TCSP")=""
- S XMSUB=SITE_"/DPN TRANSMISSION/BATCH#: "_CNTLID
- S XMTEXT="^XTMP(""RCTCSPDN"","_$J_","""_SEQ_""",""BUILD"","
- D ^XMD
- Q
- ;
- USRMSGD ;sends mailman message of documents sent to user
- N XMY,XMDUZ,XMSUB,XMTEXT,X,RCNT,RCDAT1,RCDAT2
- Q:'$D(^XTMP("RCTCSPDN",$J))
- S ACTION="DPN"
- K ^XTMP("RCTCSPDN",$J,"BILL","MSG")
- S XMDUZ="AR PACKAGE"
- S XMY("G.TCSP")=""
- S XMSUB="CS DUE PROCESS"_" SENT ON "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)_" BATCH ID: "_CNTLID
- S ^XTMP("RCTCSPDN",$J,"BILL","MSG",1)="Bill# TIN TYPE AMOUNT"
- S ^XTMP("RCTCSPDN",$J,"BILL","MSG",2)="----- --- ---- ------"
- S X=0,RCNT=2 F S X=$O(^XTMP("RCTCSPDN",$J,"BILL",ACTION,X)) Q:X="" D
- .S RCNT=RCNT+1
- .S RCDAT1=$P(^XTMP("RCTCSPDN",$J,"BILL",ACTION,X),U,1)
- .S RCDAT2=$P(^XTMP("RCTCSPDN",$J,"BILL",ACTION,X),U,2)
- .S ^XTMP("RCTCSPDN",$J,"BILL","MSG",RCNT)=$$RJZF($P($G(^PRCA(430,X,0)),U,1),7)_$$BLANK(22)_RCDAT1_" "_ACTION_" "_$S(RCDAT2]"":RCDAT2,1:"")
- .Q
- S ^XTMP("RCTCSPDN",$J,"BILL","MSG",RCNT+1)="Total Bills: "_(RCNT-2)
- S XMTEXT="^XTMP(""RCTCSPDN"","_$J_",""BILL"",""MSG"","
- Q:$G(ONEBILL)
- D ^XMD
- K ^XTMP("RCTCSPDN",$J,"BILL","MSG")
- Q
- ;
- ;increment batch sequence number, build new header
- N RCMSG
- S SEQ=SEQ+1
- S CNTLID=$$JD()_$$RJZF(SEQ,4)
- K ^XTMP("RCTCSPDN",$J,ACTION,"BUILD",SEQ)
- S RCMSG="H"_CNTLID_$$BLANK(14)_"3636001200" ;header is record type H
- S RCMSG=RCMSG_$$BLANK(250-$L(RCMSG))
- S REC=REC+1
- S ^XTMP("RCTCSPDN",$J,SEQ,"BUILD",REC)=RCMSG_$C(126)
- Q
- ;
- TRAILERD ;
- ;trailer is type Z record
- I REC=0 K ^XTMP("RCTCSPDN",$J,SEQ,"BUILD") Q ;delete batch if no records processed
- N RCMSG
- S CNTLID=$$JD()_$$RJZF(SEQ,4)
- S RCMSG="Z"_$$RJZF(RECC,8)_$$AMOUNT(AMOUNT/100)_CNTLID_$$BLANK(14)_"3636001200"
- S RCMSG=RCMSG_$$BLANK(250-$L(RCMSG))
- S:EOF $E(RCMSG,229,236)="0001"_$$RJZF(SEQ,4)
- S REC=REC+1
- S ^XTMP("RCTCSPDN",$J,SEQ,"BUILD",REC)=RCMSG_$C(126)
- S REC=0,RECC=0,AMOUNT=0
- Q
- ;
- DATE8(X) ;changes fileman date into 8 digit date yyyymmdd
- I +X S X=X+17000000
- S X=$E(X,1,8)
- Q X
- ;
- AMOUNT(X) ;changes amount to zero filled, right justified, 14 characters
- S:X<0 X=-X
- S X=$TR($J(X,0,2),".")
- S X=$E("000000000000",1,14-$L(X))_X
- Q X
- ;
- AMOUNT9(X) ;changes amount to zero filled, right justified
- S:X<0 X=-X
- S X=$TR($J(X,0,2),".")
- S X=$E("000000000000",1,9-$L(X))_X
- Q X
- ;
- BLANK(X) ;returns 'x' blank spaces
- N BLANK
- S BLANK="",$P(BLANK," ",X+1)=""
- Q BLANK
- ;
- RJZF(X,Y) ;right justify zero fill width Y
- S X=$E("000000000000",1,Y-$L(X))_X
- Q X
- ;
- LJSF(X,Y) ;left justified space filled
- S X=$E(X,1,Y)
- S X=X_$$BLANK(Y-$L(X))
- Q X
- ;
- LJZF(X,Y) ;x left justified, y zero filled
- S X=X_"0000000000"
- S X=$E(X,X,Y)
- Q X
- ;
- TAXID(DEBTOR) ;computes TAXID to place on documents
- N TAXID,DIC,DA,DR,DIQ
- S TAXID=$$SSN^RCFN01(DEBTOR)
- S TAXID=$$LJSF(TAXID,9)
- Q TAXID
- ;
- JD() ; returns today's Julian date YDOY
- N XMDDD,XMNOW,XMDT
- S XMNOW=$$NOW^XLFDT
- S XMDT=$E(XMNOW,1,7)
- S XMDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(XMDT,$E(XMDT,1,3)_"0101",1)+1,3,"0")
- Q $E(DT,3)_XMDDD
- ;
- NAMEFF(DFN) ;returns name for document and name in file
- N FN,LN,MN,NM,DOCNM,VA,VADM
- S NM=""
- D DEM^VADPT
- I $D(VADM) S NM=VADM(1)
- S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2)
- I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S MN=""
- S FN=$P($P(NM,",",2)," ")
- S DOCNM=LN_", "_FN_" "_MN
- Q DOCNM
- ;
- ADDR(RCDFN) ; returns patient file address
- N DFN,ADDRCS,STATEIEN,STATEAB,VAPA
- S DFN=RCDFN
- D ADD^VADPT
- S STATEIEN=+VAPA(5),STATEAB=$$GET1^DIQ(5,STATEIEN,1)
- S ADDRCS=VAPA(1)_U_VAPA(2)_U_VAPA(4)_U_STATEAB_U_VAPA(6)_U_VAPA(8)_U_+VAPA(25)_U_VAPA(23)_U_VAPA(24) ;25-country,23-province,24-postal code
- I $L(DEBTOR1)>0 I $P(DEBTOR1,U,1,5)'?1"^"."^" D
- .N ADDR340
- .S ADDR340=$P($$DADD^RCAMADD(DEBTOR),U,1,7)_"^"_1
- .S ADDR340=$P(ADDR340,U,1,2)_"^"_$P(ADDR340,U,4,99)
- .I $P(ADDR340,U,6)="" S $P(ADDR340,U,6)=$P(ADDRCS,U,6)
- .S ADDRCS=ADDR340
- Q ADDRCS
- ;
- REJCODE ;Converts AITC reject codes in reject multiple to pointer to file 348.5
- N RRI,REJI,REJCD,HREJREC,REJREC S RRI=0
- REJA S RRI=$O(^PRCA(430,BILL,18,RRI)) Q:'RRI
- S REJREC=$G(^PRCA(430,BILL,18,RRI,0)),HREJREC=REJREC,REJI=3 G REJA:REJREC=""
- I $D(^XTMP("REJCDCONV","BB",BILL,18,RRI,0)) G REJA
- F REJI=REJI:1:13 S REJCD=$P(REJREC,U,REJI) I REJCD'="" D
- . I REJI=12,$D(^RC(348.7,"B",REJCD)) S $P(REJREC,U,REJI)=$O(^RC(348.7,"B",REJCD,0)) Q
- . I REJI=13,$D(^RC(348.6,"B",REJCD)) S $P(REJREC,U,REJI)=$O(^RC(348.6,"B",REJCD,0)) Q
- . I REJI>11 S ^XTMP("REJCDCONV","XX",BILL,18,RRI,0)=REJI_U_HREJREC Q
- . I REJCD>9,REJCD<100 Q
- . I REJCD?1.N,((REJCD>"00")&(REJCD<"10"))!((+REJCD>0)&(+REJCD<10)) S $P(REJREC,U,REJI)=+REJCD Q
- . I $D(^RC(348.5,"B",REJCD)) S $P(REJREC,U,REJI)=$O(^RC(348.5,"B",REJCD,0)) Q
- . S $P(REJREC,U,REJI)=298,^XTMP("REJCDCONV","ZZ",BILL,18,RRI,0)=$P(HREJREC,U,REJI)
- . Q
- I HREJREC'=REJREC S ^XTMP("REJCDCONV","BB",BILL,18,RRI,0)=HREJREC,^XTMP("REJCDCONV","BB",BILL,18,RRI,1)=REJREC,^PRCA(430,BILL,18,RRI,0)=REJREC
- G REJA
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSP3 9674 printed Jan 18, 2025@02:50:01 Page 2
- RCTCSP3 ;ALBANY/BDB-CROSS-SERVICING TRANSMISSION ;03/15/14 3:34 PM
- +1 ;;4.5;Accounts Receivable;**301,315,350**;Mar 20, 1995;Build 66
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 QUIT
- +5 ;
- ENTER ;Entry point from the post initialization
- RCCSTUP IF '$DATA(^XTMP("REJCDCONV"))
- Begin DoDot:1
- +1 DO NOW^%DTC
- SET RCCSTART=%
- +2 SET ^XTMP("REJCDCONV","START COMPILE")=RCCSTART
- +3 SET ^XTMP("REJCDCONV","STATUS")="RUNNING"
- +4 SET ^XTMP("REJCDCONV",0)=$$FMADD^XLFDT(RCCSTART,730)_"^"_RCCSTART
- End DoDot:1
- +5 SET RCCCMPLT=0
- IF $GET(^XTMP("REJCDCONV","STATUS"))="COMPLETE"
- SET RCCCMPLT=1
- AA NEW DEBTOR
- +1 SET DEBTOR=0
- +2 FOR
- SET DEBTOR=$ORDER(^PRCA(430,"C",DEBTOR))
- if DEBTOR'?1N.N
- QUIT
- Begin DoDot:1
- +3 NEW X,RCDFN,DEMCS,DEBTOR0,DEBTOR1,DEBTOR7,BILL
- +4 SET DEBTOR0=^RCD(340,DEBTOR,0)
- SET DEBTOR1=$GET(^(1))
- SET DEBTOR7=$GET(^(7))
- +5 SET RCDFN=+DEBTOR0
- +6 SET DEMCS=$$DEM^RCTCSP1(RCDFN)
- if $EXTRACT($PIECE(DEMCS,U,3),1,5)="00000"
- QUIT
- +7 ;deceased patient
- if +$PIECE(DEMCS,U,4)
- QUIT
- +8 SET BILL=0
- +9 FOR
- SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
- if BILL'?1N.N
- QUIT
- Begin DoDot:2
- +10 NEW B0,B6,B7,B14,CAT,TOTAL
- +11 SET B0=$GET(^PRCA(430,BILL,0))
- SET B6=$GET(^(6))
- SET B7=$GET(^(7))
- SET B14=$GET(^(14))
- +12 IF 'RCCCMPLT
- IF $DATA(^PRCA(430,BILL,18))
- DO REJCODE
- +13 ;no dpn for cs bills
- IF $DATA(^PRCA(430,"TCSP",BILL))
- QUIT
- +14 ;no category
- if '$PIECE(B0,U,2)
- QUIT
- +15 SET CAT=$PIECE($GET(^PRCA(430.2,$PIECE(B0,U,2),0)),U,7)
- +16 if 'CAT
- QUIT
- +17 ;1st party check
- IF ",4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,25,26,27,28,33,34,35,36,37,38,39,"[(","_CAT_",")
- QUIT
- +18 ;bill referred to TOP
- IF +$PIECE(B14,U,1)
- QUIT
- +19 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
- +20 ;total must be greater than zero
- IF TOTAL'>0
- QUIT
- +21 ;if no current status
- IF '$PIECE(B0,U,8)
- QUIT
- +22 ;quit if write-off
- IF $PIECE(B0,U,8)=23
- QUIT
- +23 ;quit if cancelled
- IF $PIECE(B0,U,8)=26
- QUIT
- +24 ;quit if cancellation
- IF $PIECE(B0,U,8)=39
- QUIT
- +25 ;set dpn flag
- IF TOTAL<25
- SET $PIECE(^PRCA(430,BILL,20),U,3,8)="1^^^^^"
- +26 QUIT
- End DoDot:2
- +27 QUIT
- End DoDot:1
- +28 IF RCCCMPLT'=1
- Begin DoDot:1
- +29 DO NOW^%DTC
- SET RCCEND=%
- +30 SET ^XTMP("REJCDCONV","END REJ CODE CONV")=RCCEND
- +31 SET ^XTMP("REJCDCONV","STATUS")="COMPLETE"
- End DoDot:1
- +32 QUIT
- +33 ;
- DUEPROC ; called from rctcspd
- +1 NEW TOTAL
- +2 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
- +3 ;no dpn record for bills less than $25
- IF TOTAL<25
- QUIT
- +4 ;check site delete flag null
- IF $PIECE($GET(DEBTOR3),U,10)
- QUIT
- +5 ;check date bill sent to dmc
- IF +$PIECE(B12,U,1)
- QUIT
- +6 ;bill referred to doj
- IF $PIECE(B6,U,4)
- IF ($PIECE(B6,U,5)="DOJ")
- QUIT
- +7 ;status active
- IF $PIECE(B0,U,8)'=16
- QUIT
- +8 ;must have a 3rd letter
- IF '$PIECE(B6,U,3)
- QUIT
- +9 ;create a dpn record
- DO RECDPN
- +10 QUIT
- +11 ;
- RECDPN ;
- +1 NEW KNUM,NAME
- +2 SET REC="C"
- +3 SET REC=REC_$$RJZF(BILL,10)
- +4 SET REC=REC_$$TAXID(DEBTOR)
- +5 SET NAME=$$NAMEFF(+DEBTOR0)
- SET NAME=$PIECE(NAME,U)
- +6 SET REC=REC_$$LJSF(NAME,30)
- +7 SET RCDFN=+DEBTOR0
- +8 SET ADDRCS=$$ADDR(RCDFN)
- +9 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,1),35)_$$LJSF($PIECE(ADDRCS,U,2),35)_$$LJSF($PIECE(ADDRCS,U,3),15)
- +10 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,8),20)
- +11 SET REC=REC_$$BLANK(5)
- +12 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,4),2)_$$LJSF($PIECE(ADDRCS,U,5),9)
- +13 ;Changed routine due to SACC size issue PRCA*4.5*315
- SET REC=REC_$$COUNTRY^RCTCSP1A($PIECE(ADDRCS,U,7))
- +14 SET TOTAL=$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
- +15 SET REC=REC_$$BLANK(9)
- +16 SET REC=REC_$$DATE8(+$PIECE(B6,U,21))
- +17 SET KNUM=$PIECE($PIECE(B0,U,1),"-",2)
- +18 SET REC=REC_$EXTRACT(SITE,1,3)_$$LJSF(KNUM,7)
- +19 SET REC=REC_$$AMOUNT9(TOTAL)
- +20 SET REC=REC_$$LJSF($PIECE(ADDRCS,U,9),10)
- +21 SET REC=REC_$SELECT($PIECE(ADDRCS,U,9)="":" ",$PIECE(ADDRCS,U,9)="US":" ",1:"F")
- +22 SET REC=REC_$$BLANK(250-$LENGTH(REC))
- +23 ;set the dpn request date
- SET $PIECE(^PRCA(430,BILL,20),U,4)=DT
- +24 ;clear the print date and error codes
- SET $PIECE(^PRCA(430,BILL,20),U,5,8)="^^^"
- +25 SET ^XTMP("RCTCSPDN",$JOB,BILL,"DPN",1)=REC
- +26 ;sends mailman message of documents sent to user
- SET ^XTMP("RCTCSPDN",$JOB,"BILL","DPN",BILL)=$$TAXID(DEBTOR)_"^"_+$EXTRACT(REC,201,207)_"."_$EXTRACT(REC,208,209)
- +27 QUIT
- +28 ;
- COMPILED ;
- +1 NEW RCMSG,BCNTR,REC,RECC,AMOUNT,AMOUNT,RCNTR,ACTION,SEQ,EOF
- +2 SET BCNTR=0
- SET REC=0
- SET RECC=0
- SET AMOUNT=0
- SET SEQ=0
- SET EOF=0
- +3 FOR
- SET BCNTR=$ORDER(^XTMP("RCTCSPDN",$JOB,BCNTR))
- if +BCNTR'>0
- SET EOF=1
- if +BCNTR'>0
- QUIT
- Begin DoDot:1
- +4 IF REC>120
- Begin DoDot:2
- +5 DO TRAILERD
- +6 DO AITCMSGD
- +7 SET REC=0
- SET RECC=0
- +8 QUIT
- End DoDot:2
- +9 SET ACTION="DPN"
- +10 IF REC=0
- DO HEADERD
- +11 SET RCNTR=1
- IF $DATA(^XTMP("RCTCSPDN",$JOB,BCNTR,ACTION,RCNTR))
- Begin DoDot:2
- +12 SET REC=REC+1
- +13 ;record count for 'c' records on trailer record
- SET RECC=RECC+1
- +14 SET ^XTMP("RCTCSPDN",$JOB,SEQ,"BUILD",REC)=^XTMP("RCTCSPDN",$JOB,BCNTR,ACTION,RCNTR)_$CHAR(126)
- +15 SET AMOUNT=AMOUNT+$EXTRACT(^XTMP("RCTCSPDN",$JOB,BCNTR,ACTION,RCNTR),201,209)
- +16 QUIT
- End DoDot:2
- +17 QUIT
- End DoDot:1
- +18 DO TRAILERD
- +19 DO AITCMSGD
- +20 DO USRMSGD
- +21 QUIT
- +22 ;
- AITCMSGD ;
- +1 NEW XMY,XMDUZ,XMSUB,XMTEXT,SYSTYP
- +2 ; PRCA*4.5*350
- SET SYSTYP=$$PROD^XUPROD(1)
- +3 if '$DATA(^XTMP("RCTCSPDN",$JOB))
- QUIT
- +4 SET CNTLID=$$JD()_$$RJZF(SEQ,4)
- +5 SET XMDUZ="AR PACKAGE"
- +6 IF SYSTYP
- SET XMY("XXX@Q-TPL.DOMAIN.EXT")=""
- +7 IF 'SYSTYP
- SET XMY("XXX@Q-TXL.DOMAIN.EXT")=""
- +8 SET XMY("G.TCSP")=""
- +9 SET XMSUB=SITE_"/DPN TRANSMISSION/BATCH#: "_CNTLID
- +10 SET XMTEXT="^XTMP(""RCTCSPDN"","_$JOB_","""_SEQ_""",""BUILD"","
- +11 DO ^XMD
- +12 QUIT
- +13 ;
- USRMSGD ;sends mailman message of documents sent to user
- +1 NEW XMY,XMDUZ,XMSUB,XMTEXT,X,RCNT,RCDAT1,RCDAT2
- +2 if '$DATA(^XTMP("RCTCSPDN",$JOB))
- QUIT
- +3 SET ACTION="DPN"
- +4 KILL ^XTMP("RCTCSPDN",$JOB,"BILL","MSG")
- +5 SET XMDUZ="AR PACKAGE"
- +6 SET XMY("G.TCSP")=""
- +7 SET XMSUB="CS DUE PROCESS"_" SENT ON "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)_" BATCH ID: "_CNTLID
- +8 SET ^XTMP("RCTCSPDN",$JOB,"BILL","MSG",1)="Bill# TIN TYPE AMOUNT"
- +9 SET ^XTMP("RCTCSPDN",$JOB,"BILL","MSG",2)="----- --- ---- ------"
- +10 SET X=0
- SET RCNT=2
- FOR
- SET X=$ORDER(^XTMP("RCTCSPDN",$JOB,"BILL",ACTION,X))
- if X=""
- QUIT
- Begin DoDot:1
- +11 SET RCNT=RCNT+1
- +12 SET RCDAT1=$PIECE(^XTMP("RCTCSPDN",$JOB,"BILL",ACTION,X),U,1)
- +13 SET RCDAT2=$PIECE(^XTMP("RCTCSPDN",$JOB,"BILL",ACTION,X),U,2)
- +14 SET ^XTMP("RCTCSPDN",$JOB,"BILL","MSG",RCNT)=$$RJZF($PIECE($GET(^PRCA(430,X,0)),U,1),7)_$$BLANK(22)_RCDAT1_" "_ACTION_" "_$SELECT(RCDAT2]"":RCDAT2,1:"")
- +15 QUIT
- End DoDot:1
- +16 SET ^XTMP("RCTCSPDN",$JOB,"BILL","MSG",RCNT+1)="Total Bills: "_(RCNT-2)
- +17 SET XMTEXT="^XTMP(""RCTCSPDN"","_$JOB_",""BILL"",""MSG"","
- +18 if $GET(ONEBILL)
- QUIT
- +19 DO ^XMD
- +20 KILL ^XTMP("RCTCSPDN",$JOB,"BILL","MSG")
- +21 QUIT
- +22 ;
- +1 ;increment batch sequence number, build new header
- +2 NEW RCMSG
- +3 SET SEQ=SEQ+1
- +4 SET CNTLID=$$JD()_$$RJZF(SEQ,4)
- +5 KILL ^XTMP("RCTCSPDN",$JOB,ACTION,"BUILD",SEQ)
- +6 ;header is record type H
- SET RCMSG="H"_CNTLID_$$BLANK(14)_"3636001200"
- +7 SET RCMSG=RCMSG_$$BLANK(250-$LENGTH(RCMSG))
- +8 SET REC=REC+1
- +9 SET ^XTMP("RCTCSPDN",$JOB,SEQ,"BUILD",REC)=RCMSG_$CHAR(126)
- +10 QUIT
- +11 ;
- TRAILERD ;
- +1 ;trailer is type Z record
- +2 ;delete batch if no records processed
- IF REC=0
- KILL ^XTMP("RCTCSPDN",$JOB,SEQ,"BUILD")
- QUIT
- +3 NEW RCMSG
- +4 SET CNTLID=$$JD()_$$RJZF(SEQ,4)
- +5 SET RCMSG="Z"_$$RJZF(RECC,8)_$$AMOUNT(AMOUNT/100)_CNTLID_$$BLANK(14)_"3636001200"
- +6 SET RCMSG=RCMSG_$$BLANK(250-$LENGTH(RCMSG))
- +7 if EOF
- SET $EXTRACT(RCMSG,229,236)="0001"_$$RJZF(SEQ,4)
- +8 SET REC=REC+1
- +9 SET ^XTMP("RCTCSPDN",$JOB,SEQ,"BUILD",REC)=RCMSG_$CHAR(126)
- +10 SET REC=0
- SET RECC=0
- SET AMOUNT=0
- +11 QUIT
- +12 ;
- DATE8(X) ;changes fileman date into 8 digit date yyyymmdd
- +1 IF +X
- SET X=X+17000000
- +2 SET X=$EXTRACT(X,1,8)
- +3 QUIT X
- +4 ;
- AMOUNT(X) ;changes amount to zero filled, right justified, 14 characters
- +1 if X<0
- SET X=-X
- +2 SET X=$TRANSLATE($JUSTIFY(X,0,2),".")
- +3 SET X=$EXTRACT("000000000000",1,14-$LENGTH(X))_X
- +4 QUIT X
- +5 ;
- AMOUNT9(X) ;changes amount to zero filled, right justified
- +1 if X<0
- SET X=-X
- +2 SET X=$TRANSLATE($JUSTIFY(X,0,2),".")
- +3 SET X=$EXTRACT("000000000000",1,9-$LENGTH(X))_X
- +4 QUIT X
- +5 ;
- BLANK(X) ;returns 'x' blank spaces
- +1 NEW BLANK
- +2 SET BLANK=""
- SET $PIECE(BLANK," ",X+1)=""
- +3 QUIT BLANK
- +4 ;
- RJZF(X,Y) ;right justify zero fill width Y
- +1 SET X=$EXTRACT("000000000000",1,Y-$LENGTH(X))_X
- +2 QUIT X
- +3 ;
- LJSF(X,Y) ;left justified space filled
- +1 SET X=$EXTRACT(X,1,Y)
- +2 SET X=X_$$BLANK(Y-$LENGTH(X))
- +3 QUIT X
- +4 ;
- LJZF(X,Y) ;x left justified, y zero filled
- +1 SET X=X_"0000000000"
- +2 SET X=$EXTRACT(X,X,Y)
- +3 QUIT X
- +4 ;
- TAXID(DEBTOR) ;computes TAXID to place on documents
- +1 NEW TAXID,DIC,DA,DR,DIQ
- +2 SET TAXID=$$SSN^RCFN01(DEBTOR)
- +3 SET TAXID=$$LJSF(TAXID,9)
- +4 QUIT TAXID
- +5 ;
- JD() ; returns today's Julian date YDOY
- +1 NEW XMDDD,XMNOW,XMDT
- +2 SET XMNOW=$$NOW^XLFDT
- +3 SET XMDT=$EXTRACT(XMNOW,1,7)
- +4 SET XMDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(XMDT,$EXTRACT(XMDT,1,3)_"0101",1)+1,3,"0")
- +5 QUIT $EXTRACT(DT,3)_XMDDD
- +6 ;
- NAMEFF(DFN) ;returns name for document and name in file
- +1 NEW FN,LN,MN,NM,DOCNM,VA,VADM
- +2 SET NM=""
- +3 DO DEM^VADPT
- +4 IF $DATA(VADM)
- SET NM=VADM(1)
- +5 SET LN=$TRANSLATE($PIECE(NM,",")," .'-")
- SET MN=$PIECE($PIECE(NM,",",2)," ",2)
- +6 IF ($EXTRACT(MN,1,2)="SR")!($EXTRACT(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I")
- SET MN=""
- +7 SET FN=$PIECE($PIECE(NM,",",2)," ")
- +8 SET DOCNM=LN_", "_FN_" "_MN
- +9 QUIT DOCNM
- +10 ;
- ADDR(RCDFN) ; returns patient file address
- +1 NEW DFN,ADDRCS,STATEIEN,STATEAB,VAPA
- +2 SET DFN=RCDFN
- +3 DO ADD^VADPT
- +4 SET STATEIEN=+VAPA(5)
- SET STATEAB=$$GET1^DIQ(5,STATEIEN,1)
- +5 ;25-country,23-province,24-postal code
- SET ADDRCS=VAPA(1)_U_VAPA(2)_U_VAPA(4)_U_STATEAB_U_VAPA(6)_U_VAPA(8)_U_+VAPA(25)_U_VAPA(23)_U_VAPA(24)
- +6 IF $LENGTH(DEBTOR1)>0
- IF $PIECE(DEBTOR1,U,1,5)'?1"^"."^"
- Begin DoDot:1
- +7 NEW ADDR340
- +8 SET ADDR340=$PIECE($$DADD^RCAMADD(DEBTOR),U,1,7)_"^"_1
- +9 SET ADDR340=$PIECE(ADDR340,U,1,2)_"^"_$PIECE(ADDR340,U,4,99)
- +10 IF $PIECE(ADDR340,U,6)=""
- SET $PIECE(ADDR340,U,6)=$PIECE(ADDRCS,U,6)
- +11 SET ADDRCS=ADDR340
- End DoDot:1
- +12 QUIT ADDRCS
- +13 ;
- REJCODE ;Converts AITC reject codes in reject multiple to pointer to file 348.5
- +1 NEW RRI,REJI,REJCD,HREJREC,REJREC
- SET RRI=0
- REJA SET RRI=$ORDER(^PRCA(430,BILL,18,RRI))
- if 'RRI
- QUIT
- +1 SET REJREC=$GET(^PRCA(430,BILL,18,RRI,0))
- SET HREJREC=REJREC
- SET REJI=3
- if REJREC=""
- GOTO REJA
- +2 IF $DATA(^XTMP("REJCDCONV","BB",BILL,18,RRI,0))
- GOTO REJA
- +3 FOR REJI=REJI:1:13
- SET REJCD=$PIECE(REJREC,U,REJI)
- IF REJCD'=""
- Begin DoDot:1
- +4 IF REJI=12
- IF $DATA(^RC(348.7,"B",REJCD))
- SET $PIECE(REJREC,U,REJI)=$ORDER(^RC(348.7,"B",REJCD,0))
- QUIT
- +5 IF REJI=13
- IF $DATA(^RC(348.6,"B",REJCD))
- SET $PIECE(REJREC,U,REJI)=$ORDER(^RC(348.6,"B",REJCD,0))
- QUIT
- +6 IF REJI>11
- SET ^XTMP("REJCDCONV","XX",BILL,18,RRI,0)=REJI_U_HREJREC
- QUIT
- +7 IF REJCD>9
- IF REJCD<100
- QUIT
- +8 IF REJCD?1.N
- IF ((REJCD>"00")&(REJCD<"10"))!((+REJCD>0)&(+REJCD<10))
- SET $PIECE(REJREC,U,REJI)=+REJCD
- QUIT
- +9 IF $DATA(^RC(348.5,"B",REJCD))
- SET $PIECE(REJREC,U,REJI)=$ORDER(^RC(348.5,"B",REJCD,0))
- QUIT
- +10 SET $PIECE(REJREC,U,REJI)=298
- SET ^XTMP("REJCDCONV","ZZ",BILL,18,RRI,0)=$PIECE(HREJREC,U,REJI)
- +11 QUIT
- End DoDot:1
- +12 IF HREJREC'=REJREC
- SET ^XTMP("REJCDCONV","BB",BILL,18,RRI,0)=HREJREC
- SET ^XTMP("REJCDCONV","BB",BILL,18,RRI,1)=REJREC
- SET ^PRCA(430,BILL,18,RRI,0)=REJREC
- +13 GOTO REJA