IBY641PO ;EDE/JWS - POST-INSTALL FOR IB*2.0*641 ;13-JUL-2018
;;2.0;INTEGRATED BILLING;**641**;21-MAR-94;Build 61
;;Per VA Directive 6402, this routine should not be modified.
;
;
Q
;
EN ;Entry Point
N XSTNUM,A,B,C,D,D1,DA,DIE,DR,STATUS,PAYER,DATE,X,X1,STOP,IB3641
;
S A=0
;
S XSTNUM=$P($$SITE^VASITE,U,3)
; MARTINEZ #612
I XSTNUM=612 S A=8160000
; Boston #523
I XSTNUM=523 S A=9160000
; Orlando #675
I XSTNUM=675 S A=6000000
; Richmond #652
I XSTNUM=652 S A=8090000
; N. Chicago #556
I XSTNUM=556 S A=7020000
;
I A=0 Q ;don't run on all sites, only our 641 IOC sites
;
D CLEANUP
; only run once
Q:$D(^XTMP("IB641",0))
S ^XTMP("IB641",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"Post Install Cleanup IB*2*641 at IOC sites only"
;
F S A=$O(^IBA(364,"B",A)) Q:A'=+A D ;example 8230518
. S B=$O(^IBA(364,"B",A,0))
. S C=$O(^IBA(364,"B",A,B))
. I C="" Q ; only one with the claim numbers so quit - issue only impacts medicare secondary (aka claims that keep same number).
. S D=$O(^IBA(364,"B",A,C)) I D Q ;tertiary claim ; should never hit - 3 claims as same number
. I $P(^IBA(364,C,0),"^",3)'="P" Q ; secondary must be pending
. I $P(^IBA(364,B,0),"^",3)'="Z" Q ; primary must be closed
. I $P(^IBA(364,C,0),"^",9)="" Q ;if [9] = "", then it did not go out FHIR
. S D=0,STATUS=""
. F S D=$O(^IBM(361,"B",A,D)) Q:D="" S STOP=0,DATE=$P(^IBM(361,D,0),"^",2),PAYER="" D
.. S D1=0 F S D1=$O(^IBM(361,D,1,D1)) Q:D1'=+D1 S X=^(D1,0) D I STOP Q
... I $F(X,"CLAIM SENT TO CLEARINGHOUSE") S STATUS="A0"
... I $F(X,"Accepted Claim sent out electronically") S STATUS="A0" ;,DATE=$P(^IBM(361,D,0),"^",2)
... I $F(X,"ACCEPTED FOR PROCESSING") S STATUS="A1"
... I $F(X,"THIS CODE REQUIRES USE") S STATUS="E"
... I $F(X,"Electronic Claim rejected by Emdeon") S STATUS="E"
... I $F(X,"Payer Name: ") D I STOP Q
.... S X1=$P($P(X,"Payer ID"),"Payer Name: ",2)
.... I $F(X1,"MEDICARE") S STOP=1 Q
.... S PAYER=X1
... ;if not MEDICARE claim, reset batch number if not correct
... I PAYER="" Q
... I $P(^IBM(361,D,0),"^",11)=C Q ;checking batch pointer to see if it is needed to be corrected
... S ^XTMP("IB641","POSTINSTALL",361,D,".11")=$$GET1^DIQ(361,D_",",.11,"I")_"^"_C
... S DIE="^IBM(361",DA=D,DR=".11////"_C D ^DIE
.. I STOP S STATUS="",PAYER="",DATE=""
. S IB3641=$P(^IBA(364,C,0),"^",2)
. I $$GET1^DIQ(364,C_",",.03,"I")'=STATUS S ^XTMP("IB641","POSTINSTALL",364,C,".03")=$$GET1^DIQ(364,C_",",.03,"I")_"^"_STATUS
. I $$GET1^DIQ(364.1,IB3641_",",.02,"I")'="A0" S ^XTMP("IB641","POSTINSTALL",364.1,IB3641,".02")=$$GET1^DIQ(364.1,IB3641_",",.02,"I")_"^A0"
. I STATUS'="" D
.. I $$GET1^DIQ(364,C_",",.04,"I")'=DATE S ^XTMP("IB641","POSTINSTALL",364,C,".04")=$$GET1^DIQ(364,C_",",.04,"I")_"^"_DATE
.. I $$GET1^DIQ(364.1,IB3641_",",1.05,"I")'=DATE S ^XTMP("IB641","POSTINSTALL",364.1,IB3641,"1.05")=$$GET1^DIQ(364.1,IB3641_",",1.05,"I")_"^"_DATE
. I STATUS'="" D Q ;"Update status of 364 entry to STATUS and update 364.1
.. S DIE="^IBA(364,",DA=C,DR="" D
... I $$GET1^DIQ(364,C_",",.03,"I")'=STATUS S DR=".03////"_STATUS
... I $$GET1^DIQ(364,C_",",.04,"I")'=DATE S DR=$S(DR'="":DR_";",1:"")_".04////"_DATE
... D ^DIE
.. S DIE="^IBA(364.1",DA=IB3641,DR="" D
... I $$GET1^DIQ(364.1,IB3641_",",.02,"I")'="A0" S DR=".02////A0"
... I $$GET1^DIQ(364.1,IB3641_",",1.05,"I")'=DATE S DR=$S(DR'="":DR_";",1:"")_"1.05////"_DATE
... D ^DIE
. ; if STATUS = "", then no messages have been received yet, so set status = 'A0' and leave date the same
. I $$GET1^DIQ(364,C_",",.03,"I")'="A0" S DIE="^IBA(364,",DA=C,DR=".03////A0" D ^DIE
. I $$GET1^DIQ(364.1,IB3641_",",.02,"I")'="A0" S DIE="^IBA(364.1",DA=IB3641,DR=".02////A0" D ^DIE
. ;IBA(364,#,0)[3], [4]
. ;IBA(364.1,#,0)[2], IBA(364.1,#,1)[5]
. Q
Q
;
CLEANUP ; clean up partial 364.1 entries
;641 v15
N DIK,DA,A
S ^XTMP("IB641_364.1",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"Post Install Cleanup IB*2*641 of file 364.1 at IOC sites only"
; this loop cleans up invalid entries in file 364.1, that contain no .01 field value, no BATCH#, but have status of 'A0'
; example is:
; ^IBA(364.1,2087976,0)="^A0"
; ^IBA(364.1,2087976,1)="^^^^3200611.0015^3200611.0015"
;
; also this example, which appears to be very old:
; ^IBA(364.1,5230018828,0)="^^^^1^1^^^^^222"
; 1)="^^^^3040703.08^3040707.1049"
;
S A=0
F S A=$O(^IBA(364.1,A)) Q:A'=+A D
. I $P(^IBA(364.1,A,0),"^")="" D Q
.. M ^XTMP("IB641_364.1",A)=^IBA(364.1,A)
.. S DIK="^IBA(364.1,",DA=A D ^DIK
.. Q
. ;
. ; next is cleaning up entries caused by POSTMAN calls testing 837 FHIR and WriteBack failures
. ; resulting in:
. ; ^IBA(364.1,9450450,0)=6408882077
. ;
. I $P(^IBA(364.1,A,0),"^")'="",$P(^(0),"^",2)="" D
.. M ^XTMP("IB641_364.1",A)=^IBA(364.1,A)
.. S DIK="^IBA(364.1,",DA=A D ^DIK
.. Q
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY641PO 4922 printed Apr 09, 2024@21:23:29 Page 2
IBY641PO ;EDE/JWS - POST-INSTALL FOR IB*2.0*641 ;13-JUL-2018
+1 ;;2.0;INTEGRATED BILLING;**641**;21-MAR-94;Build 61
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
+5 QUIT
+6 ;
EN ;Entry Point
+1 NEW XSTNUM,A,B,C,D,D1,DA,DIE,DR,STATUS,PAYER,DATE,X,X1,STOP,IB3641
+2 ;
+3 SET A=0
+4 ;
+5 SET XSTNUM=$PIECE($$SITE^VASITE,U,3)
+6 ; MARTINEZ #612
+7 IF XSTNUM=612
SET A=8160000
+8 ; Boston #523
+9 IF XSTNUM=523
SET A=9160000
+10 ; Orlando #675
+11 IF XSTNUM=675
SET A=6000000
+12 ; Richmond #652
+13 IF XSTNUM=652
SET A=8090000
+14 ; N. Chicago #556
+15 IF XSTNUM=556
SET A=7020000
+16 ;
+17 ;don't run on all sites, only our 641 IOC sites
IF A=0
QUIT
+18 ;
+19 DO CLEANUP
+20 ; only run once
+21 if $DATA(^XTMP("IB641",0))
QUIT
+22 SET ^XTMP("IB641",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"Post Install Cleanup IB*2*641 at IOC sites only"
+23 ;
+24 ;example 8230518
FOR
SET A=$ORDER(^IBA(364,"B",A))
if A'=+A
QUIT
Begin DoDot:1
+25 SET B=$ORDER(^IBA(364,"B",A,0))
+26 SET C=$ORDER(^IBA(364,"B",A,B))
+27 ; only one with the claim numbers so quit - issue only impacts medicare secondary (aka claims that keep same number).
IF C=""
QUIT
+28 ;tertiary claim ; should never hit - 3 claims as same number
SET D=$ORDER(^IBA(364,"B",A,C))
IF D
QUIT
+29 ; secondary must be pending
IF $PIECE(^IBA(364,C,0),"^",3)'="P"
QUIT
+30 ; primary must be closed
IF $PIECE(^IBA(364,B,0),"^",3)'="Z"
QUIT
+31 ;if [9] = "", then it did not go out FHIR
IF $PIECE(^IBA(364,C,0),"^",9)=""
QUIT
+32 SET D=0
SET STATUS=""
+33 FOR
SET D=$ORDER(^IBM(361,"B",A,D))
if D=""
QUIT
SET STOP=0
SET DATE=$PIECE(^IBM(361,D,0),"^",2)
SET PAYER=""
Begin DoDot:2
+34 SET D1=0
FOR
SET D1=$ORDER(^IBM(361,D,1,D1))
if D1'=+D1
QUIT
SET X=^(D1,0)
Begin DoDot:3
+35 IF $FIND(X,"CLAIM SENT TO CLEARINGHOUSE")
SET STATUS="A0"
+36 ;,DATE=$P(^IBM(361,D,0),"^",2)
IF $FIND(X,"Accepted Claim sent out electronically")
SET STATUS="A0"
+37 IF $FIND(X,"ACCEPTED FOR PROCESSING")
SET STATUS="A1"
+38 IF $FIND(X,"THIS CODE REQUIRES USE")
SET STATUS="E"
+39 IF $FIND(X,"Electronic Claim rejected by Emdeon")
SET STATUS="E"
+40 IF $FIND(X,"Payer Name: ")
Begin DoDot:4
+41 SET X1=$PIECE($PIECE(X,"Payer ID"),"Payer Name: ",2)
+42 IF $FIND(X1,"MEDICARE")
SET STOP=1
QUIT
+43 SET PAYER=X1
End DoDot:4
IF STOP
QUIT
+44 ;if not MEDICARE claim, reset batch number if not correct
+45 IF PAYER=""
QUIT
+46 ;checking batch pointer to see if it is needed to be corrected
IF $PIECE(^IBM(361,D,0),"^",11)=C
QUIT
+47 SET ^XTMP("IB641","POSTINSTALL",361,D,".11")=$$GET1^DIQ(361,D_",",.11,"I")_"^"_C
+48 SET DIE="^IBM(361"
SET DA=D
SET DR=".11////"_C
DO ^DIE
End DoDot:3
IF STOP
QUIT
+49 IF STOP
SET STATUS=""
SET PAYER=""
SET DATE=""
End DoDot:2
+50 SET IB3641=$PIECE(^IBA(364,C,0),"^",2)
+51 IF $$GET1^DIQ(364,C_",",.03,"I")'=STATUS
SET ^XTMP("IB641","POSTINSTALL",364,C,".03")=$$GET1^DIQ(364,C_",",.03,"I")_"^"_STATUS
+52 IF $$GET1^DIQ(364.1,IB3641_",",.02,"I")'="A0"
SET ^XTMP("IB641","POSTINSTALL",364.1,IB3641,".02")=$$GET1^DIQ(364.1,IB3641_",",.02,"I")_"^A0"
+53 IF STATUS'=""
Begin DoDot:2
+54 IF $$GET1^DIQ(364,C_",",.04,"I")'=DATE
SET ^XTMP("IB641","POSTINSTALL",364,C,".04")=$$GET1^DIQ(364,C_",",.04,"I")_"^"_DATE
+55 IF $$GET1^DIQ(364.1,IB3641_",",1.05,"I")'=DATE
SET ^XTMP("IB641","POSTINSTALL",364.1,IB3641,"1.05")=$$GET1^DIQ(364.1,IB3641_",",1.05,"I")_"^"_DATE
End DoDot:2
+56 ;"Update status of 364 entry to STATUS and update 364.1
IF STATUS'=""
Begin DoDot:2
+57 SET DIE="^IBA(364,"
SET DA=C
SET DR=""
Begin DoDot:3
+58 IF $$GET1^DIQ(364,C_",",.03,"I")'=STATUS
SET DR=".03////"_STATUS
+59 IF $$GET1^DIQ(364,C_",",.04,"I")'=DATE
SET DR=$SELECT(DR'="":DR_";",1:"")_".04////"_DATE
+60 DO ^DIE
End DoDot:3
+61 SET DIE="^IBA(364.1"
SET DA=IB3641
SET DR=""
Begin DoDot:3
+62 IF $$GET1^DIQ(364.1,IB3641_",",.02,"I")'="A0"
SET DR=".02////A0"
+63 IF $$GET1^DIQ(364.1,IB3641_",",1.05,"I")'=DATE
SET DR=$SELECT(DR'="":DR_";",1:"")_"1.05////"_DATE
+64 DO ^DIE
End DoDot:3
End DoDot:2
QUIT
+65 ; if STATUS = "", then no messages have been received yet, so set status = 'A0' and leave date the same
+66 IF $$GET1^DIQ(364,C_",",.03,"I")'="A0"
SET DIE="^IBA(364,"
SET DA=C
SET DR=".03////A0"
DO ^DIE
+67 IF $$GET1^DIQ(364.1,IB3641_",",.02,"I")'="A0"
SET DIE="^IBA(364.1"
SET DA=IB3641
SET DR=".02////A0"
DO ^DIE
+68 ;IBA(364,#,0)[3], [4]
+69 ;IBA(364.1,#,0)[2], IBA(364.1,#,1)[5]
+70 QUIT
End DoDot:1
+71 QUIT
+72 ;
CLEANUP ; clean up partial 364.1 entries
+1 ;641 v15
+2 NEW DIK,DA,A
+3 SET ^XTMP("IB641_364.1",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"Post Install Cleanup IB*2*641 of file 364.1 at IOC sites only"
+4 ; this loop cleans up invalid entries in file 364.1, that contain no .01 field value, no BATCH#, but have status of 'A0'
+5 ; example is:
+6 ; ^IBA(364.1,2087976,0)="^A0"
+7 ; ^IBA(364.1,2087976,1)="^^^^3200611.0015^3200611.0015"
+8 ;
+9 ; also this example, which appears to be very old:
+10 ; ^IBA(364.1,5230018828,0)="^^^^1^1^^^^^222"
+11 ; 1)="^^^^3040703.08^3040707.1049"
+12 ;
+13 SET A=0
+14 FOR
SET A=$ORDER(^IBA(364.1,A))
if A'=+A
QUIT
Begin DoDot:1
+15 IF $PIECE(^IBA(364.1,A,0),"^")=""
Begin DoDot:2
+16 MERGE ^XTMP("IB641_364.1",A)=^IBA(364.1,A)
+17 SET DIK="^IBA(364.1,"
SET DA=A
DO ^DIK
+18 QUIT
End DoDot:2
QUIT
+19 ;
+20 ; next is cleaning up entries caused by POSTMAN calls testing 837 FHIR and WriteBack failures
+21 ; resulting in:
+22 ; ^IBA(364.1,9450450,0)=6408882077
+23 ;
+24 IF $PIECE(^IBA(364.1,A,0),"^")'=""
IF $PIECE(^(0),"^",2)=""
Begin DoDot:2
+25 MERGE ^XTMP("IB641_364.1",A)=^IBA(364.1,A)
+26 SET DIK="^IBA(364.1,"
SET DA=A
DO ^DIK
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 QUIT
+30 ;
