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

IBY416PO.m

Go to the documentation of this file.
  1. IBY416PO ;ALB/ESG - Post Install for IB patch 416 ;17-Aug-2009
  1. ;;2.0;INTEGRATED BILLING;**416**;21-MAR-94;Build 58
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; eIV Phase 3 Iteration 1 post-install
  1. ;
  1. EN ; entry point
  1. N XPDIDTOT
  1. S XPDIDTOT=8
  1. D PARM(1) ; 1. Set eIV parameters appropriately
  1. D PYRAPP(2) ; 2. Modify fields in eIV payer application subfile 365.121
  1. D USR(3) ; 3. Modify the IIV non-human user to be EIV
  1. D MENU(4) ; 4. Change IIV menu mnemonics to be EIV
  1. D MGRP(5) ; 5. Change the name of the IIV mail group to be EIV
  1. D MCR(6) ; 6. Medicare payer stuff
  1. D CLEARDUP(7) ; 7. Clear duplicate entries in dictionary files
  1. D RMSG(8) ; 8. Send site registration message to FSC
  1. ;
  1. EX ; exit point
  1. Q
  1. ;
  1. PARM(IBXPD) ; set eIV parameters for all extracts
  1. NEW IEN,DATA,TYB,DR,DA,DIE,DIK
  1. D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1. D MES^XPDUTL("-------------")
  1. D MES^XPDUTL("Set eIV Site Parameters ... ")
  1. ;
  1. S IEN=0
  1. F S IEN=$O(^IBE(350.9,1,51.17,IEN)) Q:'IEN D
  1. . S DATA=$G(^IBE(350.9,1,51.17,IEN,0))
  1. . S TYB=+$P(DATA,U,1)
  1. . I TYB=1 S DR=".02////1;.03////@;.04////@;.05////99999;.06////@",DA=IEN,DA(1)=1,DIE="^IBE(350.9,1,51.17," D ^DIE Q
  1. . I TYB=2 S DR=".02////1;.03////10;.04////@;.05////99999;.06////@",DA=IEN,DA(1)=1,DIE="^IBE(350.9,1,51.17," D ^DIE Q
  1. . I TYB=3 S DR=".02////0;.05////99999;.06////@",DA=IEN,DA(1)=1,DIE="^IBE(350.9,1,51.17," D ^DIE Q
  1. . I TYB=4 S DA=IEN,DA(1)=1,DIK="^IBE(350.9,1,51.17," D ^DIK Q
  1. . Q
  1. ;
  1. PARMX ;
  1. D MES^XPDUTL(" Done.")
  1. D UPDATE^XPDID(IBXPD)
  1. Q
  1. ;
  1. PYRAPP(IBXPD) ; set eIV payer application values
  1. NEW PIEN,APPIEN,IDATA,IOK,Z
  1. D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1. D MES^XPDUTL("-------------")
  1. D MES^XPDUTL("Update eIV Payer Application values ... ")
  1. ; check if this patch has already been installed once. If so, don't change payer application values.
  1. D FIND^DIC(9.7,,"@;.02","PX","IB*2.0*416",,"B",,,"IDATA")
  1. S (IOK,Z)=0 F S Z=$O(IDATA("DILIST",Z)) Q:'Z!IOK I $P(IDATA("DILIST",Z,0),U,2)="Install Completed" S IOK=1
  1. I IOK G PYRAPPX
  1. ;
  1. S PIEN=0
  1. F S PIEN=$O(^IBE(365.12,PIEN)) Q:'PIEN D
  1. . S APPIEN=+$$PYRAPP^IBCNEUT5("IIV",PIEN) Q:'APPIEN
  1. . S $P(^IBE(365.12,PIEN,1,APPIEN,0),U,7)=0 ; initial default to auto-accept NO
  1. . S $P(^IBE(365.12,PIEN,1,APPIEN,0),U,9)=0 ; use SSN for subscriber ID always NO from now on
  1. . Q
  1. ;
  1. PYRAPPX ;
  1. D MES^XPDUTL(" Done.")
  1. D UPDATE^XPDID(IBXPD)
  1. Q
  1. ;
  1. USR(IBXPD) ; change the name of the eIV non-human user
  1. NEW IDUZ,DIE,DA,DR,X,Y
  1. D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1. D MES^XPDUTL("-------------")
  1. D MES^XPDUTL("Change the name of the eIV user ... ")
  1. ;
  1. S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB IIV") ; old name to be changed
  1. I 'IDUZ G USRX ; it has already been changed or doesn't exist
  1. S DIE=200,DA=IDUZ
  1. S DR=".01////^S X=""INTERFACE,IB EIV"";1////^S X=""EIV"""
  1. D ^DIE
  1. USRX ;
  1. D MES^XPDUTL(" Done.")
  1. D UPDATE^XPDID(IBXPD)
  1. Q
  1. ;
  1. NEW MENUIEN,ITEMIEN,DIE,DA,DR,X,Y
  1. D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1. D MES^XPDUTL("-------------")
  1. D MES^XPDUTL("Updating Patient Insurance Menu mnemonic ... ")
  1. S MENUIEN=$O(^DIC(19,"B","IBCN INSURANCE MGMT MENU",0)) I 'MENUIEN D MES^XPDUTL("Parent menu not found.") G M2
  1. S ITEMIEN=$O(^DIC(19,"B","IBCNE IIV MENU",0)) I 'ITEMIEN D MES^XPDUTL("eIV Menu item not found.") G M2
  1. S DA=+$O(^DIC(19,MENUIEN,10,"B",ITEMIEN,0)) I 'DA D MES^XPDUTL("eIV Menu item not found on Pt. Ins. Menu.") G M2
  1. I $P($G(^DIC(19,MENUIEN,10,DA,0)),U,2)="EIV" D MES^XPDUTL("eIV Menu mnemonic has already been updated.") G M2
  1. S DIE="^DIC(19,"_MENUIEN_",10,"
  1. S DA(1)=MENUIEN
  1. S DR="2////EIV"
  1. D ^DIE,MES^XPDUTL("eIV Menu mnemonic updated.")
  1. M2 ;
  1. D MES^XPDUTL("Updating IB Purge Menu mnemonic ... ")
  1. S MENUIEN=$O(^DIC(19,"B","IB PURGE MENU",0)) I 'MENUIEN D MES^XPDUTL("Parent menu not found.") G MENUX
  1. S ITEMIEN=$O(^DIC(19,"B","IBCNE PURGE IIV DATA",0)) I 'ITEMIEN D MES^XPDUTL("eIV purge item not found.") G MENUX
  1. S DA=+$O(^DIC(19,MENUIEN,10,"B",ITEMIEN,0)) I 'DA D MES^XPDUTL("Purge eIV Transactions item not found on IB Purge Menu.") G MENUX
  1. I $P($G(^DIC(19,MENUIEN,10,DA,0)),U,2)="EIV" D MES^XPDUTL("eIV Purge option mnemonic has already been updated.") G MENUX
  1. S DIE="^DIC(19,"_MENUIEN_",10,"
  1. S DA(1)=MENUIEN
  1. S DR="2////EIV"
  1. D ^DIE,MES^XPDUTL("eIV Purge option mnemonic updated.")
  1. ;
  1. D MES^XPDUTL(" Done.")
  1. D UPDATE^XPDID(IBXPD)
  1. Q
  1. ;
  1. MGRP(IBXPD) ; change the eIV mail group name/desc
  1. NEW MGIEN,MGDY,IENS,IBMGD
  1. D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1. D MES^XPDUTL("-------------")
  1. D MES^XPDUTL("Updating eIV Mail Group name ... ")
  1. ;
  1. S MGIEN=$$FIND1^DIC(3.8,,"BX","IBCNE EIV MESSAGE","B")
  1. I MGIEN D MES^XPDUTL("eIV Mail Group name already changed.") G MGRPX
  1. ;
  1. S MGIEN=$$FIND1^DIC(3.8,,"BX","IBCNE IIV MESSAGE","B")
  1. I 'MGIEN D MES^XPDUTL("Can't find the old IIV mail group.") G MGRPX
  1. ;
  1. S MGDY=2
  1. S MGDY(1)="This mail group will be used to deliver notifications for"
  1. S MGDY(2)="the Insurance Verification process."
  1. ;
  1. S IENS=MGIEN_","
  1. S IBMGD(3.8,IENS,.01)="IBCNE EIV MESSAGE"
  1. S IBMGD(3.8,IENS,3)="MGDY"
  1. D FILE^DIE(,"IBMGD")
  1. D MES^XPDUTL("eIV Mail Group name updated.")
  1. ;
  1. MGRPX ;
  1. D MES^XPDUTL(" Done.")
  1. D UPDATE^XPDID(IBXPD)
  1. Q
  1. ;
  1. MCR(IBXPD) ; perform actions related to the Medicare payer
  1. NEW PAYR,LN,MSG,DIE,DA,DR,DIC,DO,ERR,APPIEN,APD,IDUZ,STOP,CNT,IBZ
  1. NEW INSLSTA,INSLSTB,INSLST,MRD,IBIFN,INS,X,Y,Z,OK,INSNM,NMUP,AMV
  1. NEW SITE,SUBJ,XMTO,XMINSTR
  1. ;
  1. D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1. D MES^XPDUTL("-------------")
  1. D MES^XPDUTL("Activating Medicare for eIV ... ")
  1. ;
  1. S LN=0,ERR=0
  1. S PAYR=+$$FIND1^DIC(365.12,"","X","MEDICARE WNR")
  1. I 'PAYR S LN=LN+1,ERR=1,MSG(LN)="Can't find the MEDICARE WNR Payer in file 365.12." G MCR1
  1. ;
  1. S DIE=350.9,DA=1,DR="51.25///"_PAYR D ^DIE K DIR,DA,DR
  1. S IBZ=+$P($G(^IBE(350.9,1,51)),U,25)
  1. S LN=LN+1,MSG(LN)="Medicare payer stored in IB site params; ien="_IBZ_"; "_$P($G(^IBE(365.12,IBZ,0)),U,1)_"."
  1. ;
  1. S APPIEN=+$$PYRAPP^IBCNEUT5("IIV",PAYR)
  1. I 'APPIEN S LN=LN+1,ERR=1,MSG(LN)="No eIV application data defined for MEDICARE WNR Payer." G MCR1
  1. ;
  1. S APD=$G(^IBE(365.12,PAYR,1,APPIEN,0))
  1. I $P(APD,U,2) S LN=LN+1,MSG(LN)="MEDICARE WNR is already nationally active."
  1. I $P(APD,U,3) S LN=LN+1,MSG(LN)="MEDICARE WNR is already locally active."
  1. S IDUZ=+$$FIND1^DIC(200,"","X","INTERFACE,IB EIV") I 'IDUZ S IDUZ=DUZ
  1. S DIE="^IBE(365.12,"_PAYR_",1,"
  1. S DA=APPIEN,DA(1)=PAYR
  1. S DR=".02///1;.03///1;.04///"_IDUZ_";.05///NOW;.06///NOW"
  1. D ^DIE K DIE,DA,DR
  1. S LN=LN+1,MSG(LN)="Payer MEDICARE WNR has been activated."
  1. ;
  1. MCR1 ; now find and process the Medicare (WNR) insurance company
  1. ;
  1. ; loop to examine recent MRA request claims at the site
  1. S STOP=0,CNT=0 K INSLSTA
  1. S MRD="" F S MRD=$O(^DGCR(399,"APM",MRD),-1) Q:MRD=""!STOP S IBIFN=0 F S IBIFN=$O(^DGCR(399,"APM",MRD,IBIFN)) Q:'IBIFN!STOP D Q:STOP
  1. . S CNT=CNT+1 I CNT>1000 S STOP=1 Q
  1. . S INS=+$P($G(^DGCR(399,IBIFN,"I1")),U,1) Q:'INS ; ins. co. ien
  1. . I '$$MCRWNR^IBEFUNC(INS) Q ; must be defined as medicare wnr
  1. . S INSLSTA(INS)=""
  1. . Q
  1. I 'STOP,CNT S LN=LN+1,ERR=1,MSG(LN)="Very few MRA request claims on file. Count="_CNT_"."
  1. I 'CNT S LN=LN+1,ERR=1,MSG(LN)="No MRA request claims found."
  1. S INS=0 F Z=0:1 S INS=$O(INSLSTA(INS)) Q:'INS
  1. I 'Z S LN=LN+1,ERR=1,MSG(LN)="No Medicare (WNR) ins co found in MRA request claims."
  1. I 'CNT!'Z S LN=LN+1,ERR=1,MSG(LN)="Value of the EDI/MRA ACTIVATED parameter: "_$$EXTERNAL^DILFD(350.9,8.1,"",$P($G(^IBE(350.9,1,8)),U,10))
  1. I Z>1 D
  1. . S LN=LN+1,ERR=1,MSG(LN)="More than 1 Medicare (WNR) ins co found in MRA request claims. "_Z_" found as follows."
  1. . S INS=0 F S INS=$O(INSLSTA(INS)) Q:'INS D
  1. .. S LN=LN+1,ERR=1,MSG(LN)=" "_$P($G(^DIC(36,INS,0)),U,1)_" ien="_INS
  1. .. Q
  1. . Q
  1. ;
  1. ; now loop through insurance company file
  1. K INSLSTB
  1. S INS=0 F S INS=$O(^DIC(36,INS)) Q:'INS D
  1. . I '$$MCRWNR^IBEFUNC(INS) Q ; check for medicare wnr
  1. . I '$$ACTIVE^IBCNEUT4(INS) Q ; check for active
  1. . S INSLSTB(INS)=""
  1. . Q
  1. S INS=0 F Z=0:1 S INS=$O(INSLSTB(INS)) Q:'INS
  1. I 'Z S LN=LN+1,ERR=1,MSG(LN)="No Medicare (WNR) ins co found in the insurance company file."
  1. I Z>1 D
  1. . S LN=LN+1,ERR=1,MSG(LN)="More than 1 Medicare (WNR) ins co found in the insurance company file. "_Z_" found as follows."
  1. . S INS=0 F S INS=$O(INSLSTB(INS)) Q:'INS D
  1. .. S LN=LN+1,ERR=1,MSG(LN)=" "_$P($G(^DIC(36,INS,0)),U,1)_" ien="_INS
  1. .. Q
  1. . Q
  1. ;
  1. ; combine the lists together and loop thru them all
  1. K INSLST
  1. M INSLST=INSLSTA,INSLST=INSLSTB
  1. S INS=0 F S INS=$O(INSLST(INS)) Q:'INS D
  1. . S INSNM=$P($G(^DIC(36,INS,0)),U,1)
  1. . S NMUP=$$UP^XLFSTR(INSNM) ; uppercase name
  1. . S OK=0
  1. . I NMUP["MEDICARE",NMUP["WNR" S OK=1
  1. . ;
  1. . ; name disqualifies this ins co from being changed
  1. . I 'OK S LN=LN+1,ERR=1,MSG(LN)="Insurance company "_INSNM_" will NOT be linked to the MEDICARE WNR payer." Q
  1. . ;
  1. . ; name is good for payer linking
  1. . I PAYR D
  1. .. S DIE=36,DA=INS,DR="3.1////"_PAYR D ^DIE K DIE,DA,DR
  1. .. S LN=LN+1,MSG(LN)="Insurance company "_INSNM_" linked to MEDICARE WNR payer."
  1. .. I INSNM'="MEDICARE (WNR)" S ERR=1 ; to be notified of these strange ones
  1. .. Q
  1. . ;
  1. . ; name is good for possibly creating these 2 Auto-Match entries
  1. . F AMV="MEDICARE","MEDICARE WNR" D
  1. .. S LN=LN+1,MSG(LN)="Attempt to add Auto-Match entry for """_AMV_"""."
  1. .. I AMV=NMUP S LN=LN+1,MSG(LN)="No Auto-Match for """_AMV_""" - same value as ins co name." Q
  1. .. I $D(^IBCN(365.11,"B",AMV)) S LN=LN+1,MSG(LN)=""""_AMV_""" already in Auto-Match file." Q
  1. .. I $D(^DIC(36,"B",AMV)) S LN=LN+1,MSG(LN)=""""_AMV_""" already an Ins Co Name." Q
  1. .. I $D(^DIC(36,"C",AMV)) S LN=LN+1,MSG(LN)=""""_AMV_""" already an Ins Co Synonym." Q
  1. .. ;
  1. .. ; OK to file this new Auto-Match entry
  1. .. K DO
  1. .. S IDUZ=+$$FIND1^DIC(200,"","X","INTERFACE,IB EIV") I 'IDUZ S IDUZ=DUZ
  1. .. S DIC="^IBCN(365.11,",DIC(0)="",X=AMV
  1. .. S DIC("DR")=".02////"_NMUP_";.03///NOW;.04///"_IDUZ_";.05///NOW;.06///"_IDUZ_";.07////"_AMV_";.08////"_NMUP
  1. .. D FILE^DICN
  1. .. I +Y>0,$P(Y,U,3) S LN=LN+1,MSG(LN)="Auto-Match entry linking """_AMV_""" with "_NMUP_" added." Q
  1. .. S LN=LN+1,ERR=1,MSG(LN)="Failure when trying to add Auto-Match entry linking """_AMV_""" with "_NMUP_"." Q
  1. .. Q
  1. . Q
  1. ;
  1. ; display the MSG array to the screen and save in the install file
  1. D MES^XPDUTL(.MSG)
  1. ;
  1. ; send email
  1. I ERR=0 G MCRX ; nothing email-worthy found
  1. I '$$PROD^XUPROD(1) G MCRX ; only email from production accounts
  1. ;
  1. S SITE=$$SITE^VASITE
  1. S SUBJ="IB*2*416 eIV Medicare Activation - #"_$P(SITE,U,3)_" - "_$P(SITE,U,2)
  1. S SUBJ=$E(SUBJ,1,65)
  1. ;
  1. S XMTO("Yan.Gurtovoy@domain.ext")=""
  1. ;
  1. S XMINSTR("FROM")="IB*2*416.Medicare.Activation"
  1. D SENDMSG^XMXAPI(DUZ,SUBJ,"MSG",.XMTO,.XMINSTR)
  1. ;
  1. MCRX ;
  1. D MES^XPDUTL(" Done.")
  1. D UPDATE^XPDID(IBXPD)
  1. Q
  1. ;
  1. CLEARDUP(IBXPD) ; clear duplicate entries in dictionary files
  1. N CODE,FILE,NESDESC,NEWIEN,OLDIEN
  1. N DA,DIE,DIK,DR,X,Y
  1. D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1. D MES^XPDUTL("-------------")
  1. D MES^XPDUTL("Cleaning dictionary files ... ")
  1. F FILE=365.011:.001:365.028 D
  1. .I '$D(^DIC(FILE)) Q
  1. .S CODE="" F S CODE=$O(^IBE(FILE,"B",CODE)) Q:CODE="" D
  1. ..S OLDIEN=$O(^IBE(FILE,"B",CODE,"")),NEWIEN=$O(^IBE(FILE,"B",CODE,""),-1)
  1. ..I OLDIEN=NEWIEN Q ; only one entry, no duplicates
  1. ..; replace description in the old entry
  1. ..S NEWDESC=$P($G(^IBE(FILE,NEWIEN,0)),U,2) I NEWDESC="" Q
  1. ..S DIE=FILE,DA=OLDIEN,DR=".02///"_NEWDESC D ^DIE
  1. ..; delete duplicate entry
  1. ..S DA=NEWIEN,DIK="^IBE("_FILE_"," D ^DIK
  1. ..Q
  1. .Q
  1. D MES^XPDUTL(" Done.")
  1. D UPDATE^XPDID(IBXPD)
  1. Q
  1. ;
  1. RMSG(IBXPD) ; send site registration message to FSC
  1. D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
  1. D MES^XPDUTL("-------------")
  1. D MES^XPDUTL("Sending site registration message to FSC ... ")
  1. I '$$PROD^XUPROD(1) D MES^XPDUTL(" N/A - not a production account") G RMSGX ; only sent reg. message from production account
  1. D ^IBCNEHLM
  1. D MES^XPDUTL(" Done.")
  1. RMSGX ;
  1. D UPDATE^XPDID(IBXPD)
  1. Q