Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBY641PO

IBY641PO.m

Go to the documentation of this file.
  1. IBY641PO ;EDE/JWS - POST-INSTALL FOR IB*2.0*641 ;13-JUL-2018
  1. ;;2.0;INTEGRATED BILLING;**641**;21-MAR-94;Build 61
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;
  1. Q
  1. ;
  1. EN ;Entry Point
  1. N XSTNUM,A,B,C,D,D1,DA,DIE,DR,STATUS,PAYER,DATE,X,X1,STOP,IB3641
  1. ;
  1. S A=0
  1. ;
  1. S XSTNUM=$P($$SITE^VASITE,U,3)
  1. ; MARTINEZ #612
  1. I XSTNUM=612 S A=8160000
  1. ; Boston #523
  1. I XSTNUM=523 S A=9160000
  1. ; Orlando #675
  1. I XSTNUM=675 S A=6000000
  1. ; Richmond #652
  1. I XSTNUM=652 S A=8090000
  1. ; N. Chicago #556
  1. I XSTNUM=556 S A=7020000
  1. ;
  1. I A=0 Q ;don't run on all sites, only our 641 IOC sites
  1. ;
  1. D CLEANUP
  1. ; only run once
  1. Q:$D(^XTMP("IB641",0))
  1. S ^XTMP("IB641",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"Post Install Cleanup IB*2*641 at IOC sites only"
  1. ;
  1. F S A=$O(^IBA(364,"B",A)) Q:A'=+A D ;example 8230518
  1. . S B=$O(^IBA(364,"B",A,0))
  1. . S C=$O(^IBA(364,"B",A,B))
  1. . I C="" Q ; only one with the claim numbers so quit - issue only impacts medicare secondary (aka claims that keep same number).
  1. . S D=$O(^IBA(364,"B",A,C)) I D Q ;tertiary claim ; should never hit - 3 claims as same number
  1. . I $P(^IBA(364,C,0),"^",3)'="P" Q ; secondary must be pending
  1. . I $P(^IBA(364,B,0),"^",3)'="Z" Q ; primary must be closed
  1. . I $P(^IBA(364,C,0),"^",9)="" Q ;if [9] = "", then it did not go out FHIR
  1. . S D=0,STATUS=""
  1. . F S D=$O(^IBM(361,"B",A,D)) Q:D="" S STOP=0,DATE=$P(^IBM(361,D,0),"^",2),PAYER="" D
  1. .. S D1=0 F S D1=$O(^IBM(361,D,1,D1)) Q:D1'=+D1 S X=^(D1,0) D I STOP Q
  1. ... I $F(X,"CLAIM SENT TO CLEARINGHOUSE") S STATUS="A0"
  1. ... I $F(X,"Accepted Claim sent out electronically") S STATUS="A0" ;,DATE=$P(^IBM(361,D,0),"^",2)
  1. ... I $F(X,"ACCEPTED FOR PROCESSING") S STATUS="A1"
  1. ... I $F(X,"THIS CODE REQUIRES USE") S STATUS="E"
  1. ... I $F(X,"Electronic Claim rejected by Emdeon") S STATUS="E"
  1. ... I $F(X,"Payer Name: ") D I STOP Q
  1. .... S X1=$P($P(X,"Payer ID"),"Payer Name: ",2)
  1. .... I $F(X1,"MEDICARE") S STOP=1 Q
  1. .... S PAYER=X1
  1. ... ;if not MEDICARE claim, reset batch number if not correct
  1. ... I PAYER="" Q
  1. ... I $P(^IBM(361,D,0),"^",11)=C Q ;checking batch pointer to see if it is needed to be corrected
  1. ... S ^XTMP("IB641","POSTINSTALL",361,D,".11")=$$GET1^DIQ(361,D_",",.11,"I")_"^"_C
  1. ... S DIE="^IBM(361",DA=D,DR=".11////"_C D ^DIE
  1. .. I STOP S STATUS="",PAYER="",DATE=""
  1. . S IB3641=$P(^IBA(364,C,0),"^",2)
  1. . I $$GET1^DIQ(364,C_",",.03,"I")'=STATUS S ^XTMP("IB641","POSTINSTALL",364,C,".03")=$$GET1^DIQ(364,C_",",.03,"I")_"^"_STATUS
  1. . 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"
  1. . I STATUS'="" D
  1. .. I $$GET1^DIQ(364,C_",",.04,"I")'=DATE S ^XTMP("IB641","POSTINSTALL",364,C,".04")=$$GET1^DIQ(364,C_",",.04,"I")_"^"_DATE
  1. .. 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
  1. . I STATUS'="" D Q ;"Update status of 364 entry to STATUS and update 364.1
  1. .. S DIE="^IBA(364,",DA=C,DR="" D
  1. ... I $$GET1^DIQ(364,C_",",.03,"I")'=STATUS S DR=".03////"_STATUS
  1. ... I $$GET1^DIQ(364,C_",",.04,"I")'=DATE S DR=$S(DR'="":DR_";",1:"")_".04////"_DATE
  1. ... D ^DIE
  1. .. S DIE="^IBA(364.1",DA=IB3641,DR="" D
  1. ... I $$GET1^DIQ(364.1,IB3641_",",.02,"I")'="A0" S DR=".02////A0"
  1. ... I $$GET1^DIQ(364.1,IB3641_",",1.05,"I")'=DATE S DR=$S(DR'="":DR_";",1:"")_"1.05////"_DATE
  1. ... D ^DIE
  1. . ; if STATUS = "", then no messages have been received yet, so set status = 'A0' and leave date the same
  1. . I $$GET1^DIQ(364,C_",",.03,"I")'="A0" S DIE="^IBA(364,",DA=C,DR=".03////A0" D ^DIE
  1. . I $$GET1^DIQ(364.1,IB3641_",",.02,"I")'="A0" S DIE="^IBA(364.1",DA=IB3641,DR=".02////A0" D ^DIE
  1. . ;IBA(364,#,0)[3], [4]
  1. . ;IBA(364.1,#,0)[2], IBA(364.1,#,1)[5]
  1. . Q
  1. Q
  1. ;
  1. CLEANUP ; clean up partial 364.1 entries
  1. ;641 v15
  1. N DIK,DA,A
  1. 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"
  1. ; this loop cleans up invalid entries in file 364.1, that contain no .01 field value, no BATCH#, but have status of 'A0'
  1. ; example is:
  1. ; ^IBA(364.1,2087976,0)="^A0"
  1. ; ^IBA(364.1,2087976,1)="^^^^3200611.0015^3200611.0015"
  1. ;
  1. ; also this example, which appears to be very old:
  1. ; ^IBA(364.1,5230018828,0)="^^^^1^1^^^^^222"
  1. ; 1)="^^^^3040703.08^3040707.1049"
  1. ;
  1. S A=0
  1. F S A=$O(^IBA(364.1,A)) Q:A'=+A D
  1. . I $P(^IBA(364.1,A,0),"^")="" D Q
  1. .. M ^XTMP("IB641_364.1",A)=^IBA(364.1,A)
  1. .. S DIK="^IBA(364.1,",DA=A D ^DIK
  1. .. Q
  1. . ;
  1. . ; next is cleaning up entries caused by POSTMAN calls testing 837 FHIR and WriteBack failures
  1. . ; resulting in:
  1. . ; ^IBA(364.1,9450450,0)=6408882077
  1. . ;
  1. . I $P(^IBA(364.1,A,0),"^")'="",$P(^(0),"^",2)="" D
  1. .. M ^XTMP("IB641_364.1",A)=^IBA(364.1,A)
  1. .. S DIK="^IBA(364.1,",DA=A D ^DIK
  1. .. Q
  1. . Q
  1. Q
  1. ;