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 Apr 09, 2024@21:36:55 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
