RCDPEM8 ;OIFO-BAYPINES/PJH - EOB MOVE/COPY BULLETINS ;Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**276,298**;Mar 20, 1995;Build 121
;Per VA Directive 6402, this routine should not be modified.
;
EN ; Main entry point for Moved/Copied EOB bulletins
;
; Integration Agreement IA 451 allows read of file #361.1 from AR
;
N EOBCNT,RCPROG
;Clear workfiles
S RCPROG="RCDPEM8" K ^TMP(RCPROG,$J)
;Set count of EOB found
S EOBCNT=0
;
;Scan for today's moved/copied EOB's
D EOBSCAN
;-----
; PRCA*4.5*298 - MailMan message disabled, logic retained - 14 Feb 2014
;Bulletin
;I EOBCNT D BULLETIN
;-----
;Clear workfiles
K ^TMP(RCPROG,$J)
Q
;
EOBSCAN ;Scan EOB
N CDATE,CNT,DONE,EOBIEN,IEN101,NOW
;Start day for scan is yesterday
S NOW=$$NOW^XLFDT,CDATE=$$FMADD^XLFDT($P(NOW,"."),-1)
;Scan AEOB index for changed EOBs
F S CDATE=$O(^IBM(361.1,"AEOB",CDATE)) Q:'CDATE D
.;Check if change was over 24 hours ago
.I $$FMDIFF^XLFDT(NOW,CDATE,2)>86400 Q
.;Skip this transaction if all referenced claims are active
.Q:'$$INACTIVE(CDATE)
.;Otherwise save bulletin details for EOB's in the transaction
.S EOBIEN="",CNT=0,EOBCNT=EOBCNT+1
.F S EOBIEN=$O(^IBM(361.1,"AEOB",CDATE,EOBIEN)) Q:'EOBIEN D
..;Update counter
..S CNT=CNT+1
..S IEN101=$O(^IBM(361.1,"AEOB",CDATE,EOBIEN,"")) Q:'IEN101
..;Save to workfile
..D SAVE(CDATE,EOBIEN,IEN101,EOBCNT,CNT)
Q
;
INACTIVE(CDATE) ;Search for any bill that is not ACTIVE
N CBILL,FBILL,FOUND,REC101,SUB,SUB101
S SUB=0,FOUND=0
F S SUB=$O(^IBM(361.1,"AEOB",CDATE,SUB)) Q:'SUB D Q:FOUND
.S SUB101=0
.F S SUB101=$O(^IBM(361.1,"AEOB",CDATE,SUB,SUB101)) Q:'SUB101 D Q:FOUND
..S REC101=$G(^IBM(361.1,SUB,101,SUB101,0))
..;From bill
..S FBILL=$P(REC101,U,4)
..I FBILL S FOUND=$$CHECK(FBILL) Q:FOUND
..;Current bill on EOB
..S CBILL=$P($G(^IBM(361.1,SUB,0)),U)
..;AR claim status
..I CBILL S FOUND=$$CHECK(CBILL)
Q FOUND
;
CHECK(IEN430) ;Check claim status in AR
I $$GET1^DIQ(430,IEN430,8)="ACTIVE" Q 0
Q 1
;
SAVE(CDATE,EOBIEN,IEN101,EOBCNT,CNT) ;Put the data into the ^TMP global
; INPUTS: EOBIEN = ien of the EOB
; IEN101 = ien of individual copy
; EOBCNT = count of EOB found
; CNT = count of claims within transaction
; RETURNS : Builds each entry in the ^TMP global
;
N BIEN,BEXT,DATE,DOS,PATIEN,PATNAM,PIEN,PEXT,PSQ,PSQEXT,REC0,STAT
N REC101,ORIG,MODE
;Get EOB detail
S REC0=$G(^IBM(361.1,EOBIEN,0))
;Bill pointer
S BIEN=$P(REC0,U) Q:'BIEN
;Get audit detail
S REC101=$G(^IBM(361.1,EOBIEN,101,IEN101,0))
;Mode and Original claim
S ORIG=$P(REC101,U,4),MODE=$P(REC101,U,5)
;
;If transaction is a move the only EOB is on the new claim
;
;Create report line for original claim
I MODE="M",ORIG D
.N BIEN
.S BIEN=ORIG D SAVE1 S CNT=CNT+1
;
;Save transaction for to bill
D SAVE1
Q
;
SAVE1 ;Save unformatted bill details into ^TMP
;
;Get Bill number from bill IEN
S BEXT=$P($G(^PRCA(430,BIEN,0)),U)
;Patient IEN
S PATIEN=$P($G(^DGCR(399,BIEN,0)),U,2)
;Patient Name
S PATNAM=$$EXTERNAL^DILFD(399,.02,,PATIEN)
;DOS
S DOS=$$FMTE^XLFDT($P($G(^DGCR(399,BIEN,0)),U,3),"2D")
;Payer
S PIEN=$P(REC0,U,2)
;Payer external form
S PEXT=$$EXTERNAL^DILFD(361.1,.02,,PIEN)
;If no payer name on EOB check AR claim
I PEXT="" S PEXT=$$GET1^DIQ(430,BIEN,9)
;Truncate payer name to 18 characters
S PEXT=$E(PEXT,1,18)
;Payer Sequence
S PSQ=$P(REC0,U,15)
;Payer sequence - external
S PSQEXT=$$EXTERNAL^DILFD(361.1,.15,,PSQ)
;Display sequence if not null
S:PSQEXT]"" PEXT=PEXT_"/"_PSQEXT
;AR claim status
S STAT=$$GET1^DIQ(430,BIEN,8)
;Date/Time EOB was moved/copied
S DATE=$$FMTE^XLFDT(CDATE,"2S")
;
S ^TMP(RCPROG,$J,EOBCNT,CNT)=DATE_U_BEXT_U_PATNAM_U_DOS_U_PEXT_U_STAT
Q
;
BULLETIN ;Create bulletins only if moved/copied EOB found
;
N ARRAY,BLANK,SBJ,SUB,SUBHDR,SUBHDR1,SUBHDR2,CNT,CNT1,RCPROG1,GLB
N LINE,DET
S RCPROG1="RCDPEM8A",GLB=$NA(^TMP(RCPROG1,$J,"XMTEXT"))
;
;Compile Move/Copy Transactions Bulletin
;Build header
K @GLB
S SBJ="EDI LBOX-STA# "_$P($$SITE^VASITE,"^",3)_"-Move/Copy Transactions"
S @GLB@(1)="The listed Move/Copy transaction(s) were performed within the last 24 hours"
S @GLB@(2)="and at least one of the claims in each of the transactions was NOT ACTIVE."
S @GLB@(3)=" "
S @GLB@(4)="Total # of transactions - "_EOBCNT
S @GLB@(6)=" "
S @GLB@(7)="BILL # PATIENT DOS PAYER/SEQUENCE"
S @GLB@(8)=" STATUS"
S @GLB@(9)="----------------------------------------------------------------------------"
;
;Sub headers
S SUBHDR="Transaction "
S SUBHDR1=" - 'MOVE/COPY FROM' bill "
S SUBHDR2=" 'MOVE/COPY TO' bill(s)"
S BLANK=$J("",75)
;
;Move EOB search findings into message
S EOBCNT="",CNT1=9
F S EOBCNT=$O(^TMP(RCPROG,$J,EOBCNT)) Q:'EOBCNT D
.S CNT=0
.F S CNT=$O(^TMP(RCPROG,$J,EOBCNT,CNT)) Q:'CNT D
..;EOB data from scan
..S DET=$G(^TMP(RCPROG,$J,EOBCNT,CNT))
..;Check if 'From' or 'To'
..I CNT=1 S LINE=SUBHDR_EOBCNT_SUBHDR1_$P(DET,U)
..E S LINE=SUBHDR2
..S CNT1=CNT1+1,@GLB@(CNT1)=LINE
..S CNT1=CNT1+1,@GLB@(CNT1)=$$EOBL(DET)
..S CNT1=CNT1+1,@GLB@(CNT1)=" "_$P(DET,U,6)
..S CNT1=CNT1+1,@GLB@(CNT1)=BLANK
S @GLB@(CNT1+1)="** END OF REPORT **"
;
;Transmit mail message
N XMDUZ,XMTEXT,XMSUB,XMY,XMINSTR
S XMDUZ=DUZ,XMTEXT=GLB,XMSUB=SBJ,XMY("I:G.RCDPE MOVE COPY")=""
S XMINSTR("FROM")="POSTMASTER"
D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.XMINSTR)
K @GLB
Q
;
;
EOBL(DET) ;Format EOB line
N BILL,DOS,PATIENT,PAYER,OUTPUT,SP
S BILL=$P(DET,U,2),PATIENT=$P(DET,U,3),DOS=$P(DET,U,4),SP=$J("",80)
S PAYER=$P(DET,U,5)
;Truncate patient name
S PATIENT=$E(PATIENT,1,19)
;Bill number
S OUTPUT=BILL_$E(SP,1,12-$L(BILL))
;Patient
S OUTPUT=OUTPUT_PATIENT_$E(SP,1,20-$L(PATIENT))
;DOS
S OUTPUT=OUTPUT_DOS_$E(SP,1,13-$L(DOS))
;Payer
S OUTPUT=OUTPUT_PAYER
;
Q OUTPUT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEM8 5993 printed Oct 16, 2024@17:45:43 Page 2
RCDPEM8 ;OIFO-BAYPINES/PJH - EOB MOVE/COPY BULLETINS ;Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**276,298**;Mar 20, 1995;Build 121
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; Main entry point for Moved/Copied EOB bulletins
+1 ;
+2 ; Integration Agreement IA 451 allows read of file #361.1 from AR
+3 ;
+4 NEW EOBCNT,RCPROG
+5 ;Clear workfiles
+6 SET RCPROG="RCDPEM8"
KILL ^TMP(RCPROG,$JOB)
+7 ;Set count of EOB found
+8 SET EOBCNT=0
+9 ;
+10 ;Scan for today's moved/copied EOB's
+11 DO EOBSCAN
+12 ;-----
+13 ; PRCA*4.5*298 - MailMan message disabled, logic retained - 14 Feb 2014
+14 ;Bulletin
+15 ;I EOBCNT D BULLETIN
+16 ;-----
+17 ;Clear workfiles
+18 KILL ^TMP(RCPROG,$JOB)
+19 QUIT
+20 ;
EOBSCAN ;Scan EOB
+1 NEW CDATE,CNT,DONE,EOBIEN,IEN101,NOW
+2 ;Start day for scan is yesterday
+3 SET NOW=$$NOW^XLFDT
SET CDATE=$$FMADD^XLFDT($PIECE(NOW,"."),-1)
+4 ;Scan AEOB index for changed EOBs
+5 FOR
SET CDATE=$ORDER(^IBM(361.1,"AEOB",CDATE))
if 'CDATE
QUIT
Begin DoDot:1
+6 ;Check if change was over 24 hours ago
+7 IF $$FMDIFF^XLFDT(NOW,CDATE,2)>86400
QUIT
+8 ;Skip this transaction if all referenced claims are active
+9 if '$$INACTIVE(CDATE)
QUIT
+10 ;Otherwise save bulletin details for EOB's in the transaction
+11 SET EOBIEN=""
SET CNT=0
SET EOBCNT=EOBCNT+1
+12 FOR
SET EOBIEN=$ORDER(^IBM(361.1,"AEOB",CDATE,EOBIEN))
if 'EOBIEN
QUIT
Begin DoDot:2
+13 ;Update counter
+14 SET CNT=CNT+1
+15 SET IEN101=$ORDER(^IBM(361.1,"AEOB",CDATE,EOBIEN,""))
if 'IEN101
QUIT
+16 ;Save to workfile
+17 DO SAVE(CDATE,EOBIEN,IEN101,EOBCNT,CNT)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
INACTIVE(CDATE) ;Search for any bill that is not ACTIVE
+1 NEW CBILL,FBILL,FOUND,REC101,SUB,SUB101
+2 SET SUB=0
SET FOUND=0
+3 FOR
SET SUB=$ORDER(^IBM(361.1,"AEOB",CDATE,SUB))
if 'SUB
QUIT
Begin DoDot:1
+4 SET SUB101=0
+5 FOR
SET SUB101=$ORDER(^IBM(361.1,"AEOB",CDATE,SUB,SUB101))
if 'SUB101
QUIT
Begin DoDot:2
+6 SET REC101=$GET(^IBM(361.1,SUB,101,SUB101,0))
+7 ;From bill
+8 SET FBILL=$PIECE(REC101,U,4)
+9 IF FBILL
SET FOUND=$$CHECK(FBILL)
if FOUND
QUIT
+10 ;Current bill on EOB
+11 SET CBILL=$PIECE($GET(^IBM(361.1,SUB,0)),U)
+12 ;AR claim status
+13 IF CBILL
SET FOUND=$$CHECK(CBILL)
End DoDot:2
if FOUND
QUIT
End DoDot:1
if FOUND
QUIT
+14 QUIT FOUND
+15 ;
CHECK(IEN430) ;Check claim status in AR
+1 IF $$GET1^DIQ(430,IEN430,8)="ACTIVE"
QUIT 0
+2 QUIT 1
+3 ;
SAVE(CDATE,EOBIEN,IEN101,EOBCNT,CNT) ;Put the data into the ^TMP global
+1 ; INPUTS: EOBIEN = ien of the EOB
+2 ; IEN101 = ien of individual copy
+3 ; EOBCNT = count of EOB found
+4 ; CNT = count of claims within transaction
+5 ; RETURNS : Builds each entry in the ^TMP global
+6 ;
+7 NEW BIEN,BEXT,DATE,DOS,PATIEN,PATNAM,PIEN,PEXT,PSQ,PSQEXT,REC0,STAT
+8 NEW REC101,ORIG,MODE
+9 ;Get EOB detail
+10 SET REC0=$GET(^IBM(361.1,EOBIEN,0))
+11 ;Bill pointer
+12 SET BIEN=$PIECE(REC0,U)
if 'BIEN
QUIT
+13 ;Get audit detail
+14 SET REC101=$GET(^IBM(361.1,EOBIEN,101,IEN101,0))
+15 ;Mode and Original claim
+16 SET ORIG=$PIECE(REC101,U,4)
SET MODE=$PIECE(REC101,U,5)
+17 ;
+18 ;If transaction is a move the only EOB is on the new claim
+19 ;
+20 ;Create report line for original claim
+21 IF MODE="M"
IF ORIG
Begin DoDot:1
+22 NEW BIEN
+23 SET BIEN=ORIG
DO SAVE1
SET CNT=CNT+1
End DoDot:1
+24 ;
+25 ;Save transaction for to bill
+26 DO SAVE1
+27 QUIT
+28 ;
SAVE1 ;Save unformatted bill details into ^TMP
+1 ;
+2 ;Get Bill number from bill IEN
+3 SET BEXT=$PIECE($GET(^PRCA(430,BIEN,0)),U)
+4 ;Patient IEN
+5 SET PATIEN=$PIECE($GET(^DGCR(399,BIEN,0)),U,2)
+6 ;Patient Name
+7 SET PATNAM=$$EXTERNAL^DILFD(399,.02,,PATIEN)
+8 ;DOS
+9 SET DOS=$$FMTE^XLFDT($PIECE($GET(^DGCR(399,BIEN,0)),U,3),"2D")
+10 ;Payer
+11 SET PIEN=$PIECE(REC0,U,2)
+12 ;Payer external form
+13 SET PEXT=$$EXTERNAL^DILFD(361.1,.02,,PIEN)
+14 ;If no payer name on EOB check AR claim
+15 IF PEXT=""
SET PEXT=$$GET1^DIQ(430,BIEN,9)
+16 ;Truncate payer name to 18 characters
+17 SET PEXT=$EXTRACT(PEXT,1,18)
+18 ;Payer Sequence
+19 SET PSQ=$PIECE(REC0,U,15)
+20 ;Payer sequence - external
+21 SET PSQEXT=$$EXTERNAL^DILFD(361.1,.15,,PSQ)
+22 ;Display sequence if not null
+23 if PSQEXT]""
SET PEXT=PEXT_"/"_PSQEXT
+24 ;AR claim status
+25 SET STAT=$$GET1^DIQ(430,BIEN,8)
+26 ;Date/Time EOB was moved/copied
+27 SET DATE=$$FMTE^XLFDT(CDATE,"2S")
+28 ;
+29 SET ^TMP(RCPROG,$JOB,EOBCNT,CNT)=DATE_U_BEXT_U_PATNAM_U_DOS_U_PEXT_U_STAT
+30 QUIT
+31 ;
BULLETIN ;Create bulletins only if moved/copied EOB found
+1 ;
+2 NEW ARRAY,BLANK,SBJ,SUB,SUBHDR,SUBHDR1,SUBHDR2,CNT,CNT1,RCPROG1,GLB
+3 NEW LINE,DET
+4 SET RCPROG1="RCDPEM8A"
SET GLB=$NAME(^TMP(RCPROG1,$JOB,"XMTEXT"))
+5 ;
+6 ;Compile Move/Copy Transactions Bulletin
+7 ;Build header
+8 KILL @GLB
+9 SET SBJ="EDI LBOX-STA# "_$PIECE($$SITE^VASITE,"^",3)_"-Move/Copy Transactions"
+10 SET @GLB@(1)="The listed Move/Copy transaction(s) were performed within the last 24 hours"
+11 SET @GLB@(2)="and at least one of the claims in each of the transactions was NOT ACTIVE."
+12 SET @GLB@(3)=" "
+13 SET @GLB@(4)="Total # of transactions - "_EOBCNT
+14 SET @GLB@(6)=" "
+15 SET @GLB@(7)="BILL # PATIENT DOS PAYER/SEQUENCE"
+16 SET @GLB@(8)=" STATUS"
+17 SET @GLB@(9)="----------------------------------------------------------------------------"
+18 ;
+19 ;Sub headers
+20 SET SUBHDR="Transaction "
+21 SET SUBHDR1=" - 'MOVE/COPY FROM' bill "
+22 SET SUBHDR2=" 'MOVE/COPY TO' bill(s)"
+23 SET BLANK=$JUSTIFY("",75)
+24 ;
+25 ;Move EOB search findings into message
+26 SET EOBCNT=""
SET CNT1=9
+27 FOR
SET EOBCNT=$ORDER(^TMP(RCPROG,$JOB,EOBCNT))
if 'EOBCNT
QUIT
Begin DoDot:1
+28 SET CNT=0
+29 FOR
SET CNT=$ORDER(^TMP(RCPROG,$JOB,EOBCNT,CNT))
if 'CNT
QUIT
Begin DoDot:2
+30 ;EOB data from scan
+31 SET DET=$GET(^TMP(RCPROG,$JOB,EOBCNT,CNT))
+32 ;Check if 'From' or 'To'
+33 IF CNT=1
SET LINE=SUBHDR_EOBCNT_SUBHDR1_$PIECE(DET,U)
+34 IF '$TEST
SET LINE=SUBHDR2
+35 SET CNT1=CNT1+1
SET @GLB@(CNT1)=LINE
+36 SET CNT1=CNT1+1
SET @GLB@(CNT1)=$$EOBL(DET)
+37 SET CNT1=CNT1+1
SET @GLB@(CNT1)=" "_$PIECE(DET,U,6)
+38 SET CNT1=CNT1+1
SET @GLB@(CNT1)=BLANK
End DoDot:2
End DoDot:1
+39 SET @GLB@(CNT1+1)="** END OF REPORT **"
+40 ;
+41 ;Transmit mail message
+42 NEW XMDUZ,XMTEXT,XMSUB,XMY,XMINSTR
+43 SET XMDUZ=DUZ
SET XMTEXT=GLB
SET XMSUB=SBJ
SET XMY("I:G.RCDPE MOVE COPY")=""
+44 SET XMINSTR("FROM")="POSTMASTER"
+45 DO SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.XMINSTR)
+46 KILL @GLB
+47 QUIT
+48 ;
+49 ;
EOBL(DET) ;Format EOB line
+1 NEW BILL,DOS,PATIENT,PAYER,OUTPUT,SP
+2 SET BILL=$PIECE(DET,U,2)
SET PATIENT=$PIECE(DET,U,3)
SET DOS=$PIECE(DET,U,4)
SET SP=$JUSTIFY("",80)
+3 SET PAYER=$PIECE(DET,U,5)
+4 ;Truncate patient name
+5 SET PATIENT=$EXTRACT(PATIENT,1,19)
+6 ;Bill number
+7 SET OUTPUT=BILL_$EXTRACT(SP,1,12-$LENGTH(BILL))
+8 ;Patient
+9 SET OUTPUT=OUTPUT_PATIENT_$EXTRACT(SP,1,20-$LENGTH(PATIENT))
+10 ;DOS
+11 SET OUTPUT=OUTPUT_DOS_$EXTRACT(SP,1,13-$LENGTH(DOS))
+12 ;Payer
+13 SET OUTPUT=OUTPUT_PAYER
+14 ;
+15 QUIT OUTPUT
