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