IBY519PO ;ALB/GEF - Post install routine for patch 519 ; 21-FEB-14
;;2.0;INTEGRATED BILLING;**519**;21-MAR-94;Build 56
;;Per VA Directive 6402, this routine should not be modified.
;
; Call to XUPROD is allowed with IA#4440
; XPDUTL calls are DBIA#10141
; ZTQUEUED is a KIDS variable that indicates if the user queued the install. This variable should not
; be killed or newed here
;
D EN
Q
DOC ; This routine will Create Data Extract EMAILS from Each VAMC to FSC for Initial Seeding of NIF
;
; Each VistA site will submit a data extract in the form of one or more emails as defined in
; the ICD. This data extract is to happen only once at each of the VAMC after the patch
; IB*2.0*519 is nationally released upon direction of the VA's Chief Business Office's (CBO)
; eInsurance team. FSC will load the data from these flat files into the FSC Staging table.
; The data within the FSC Staging table will be used to identify a consolidated list of payers
;(insurance companies) across all VAMCs which will then be used to initially populated (seed)
; the VA National Insurance File (NIF).
;
; Types of Records: HEADER (HDR), PAYER (INS), TRAILER (EOF)
; * Each VAMC will have 1 HEADER record and 1 TRAILER record, with 1 to many PAYER records in between the two.
; Delimiter = "^"
;
; Data output:
; HDR^Station #^Site name
; INS^Stn#^Ins.Co.ien^NAME^EDI PROF^EDI INST^QUAL^2NDARY I1^QUAL^2ND I2^QUAL^2ND P1^QUAL^2ND P2^VA NTL ID^STR ADR 1^ADR2^CITY^ST^ZIP^BILL NM^PH^TYP OF COVG
; EOF^Stn#^Site
;
; Search criteria:
; 1. Insurance Company entry in file #36 must be ACTIVE (field #.05 '=1)
; 2. There must be patients associated with the Ins.Co. (^DPT("AB",INS))
; 3. There must be groups associated with the Ins. Co. (^IBA(355.3,"B",INS))
;
; note the following:
; 3.1 PAYER (*P365.12'), [3;10] populate with VA NATIONAL ID only if
; Payer file #365.13 application "IIV" is locally & nationally active
;
Q
EN ; Post Install Routine primary entry point
;
N IBPRD,DIC,X,Y,DIE,DR,DA
; Call to XUPROD allowed by IA#4440
S IBPRD=$S($$PROD^XUPROD(1)=1:"P",1:"T")
;Stuff FSC domain into link
S DIC="^HLCS(870,",DIC(0)="LS" S X="IB NIF TCP" D ^DIC
; For test environments, use the FSC test domain
I IBPRD="T",Y'=-1 S DIE=DIC,DA=+Y,DR=".08///ECOMMLLPTST.FSC.DOMAIN.EXT;400.02///9346;4.5///1" K DIC D ^DIE
; For Production environments, use the FSC PRD domain
I IBPRD="P",Y'=-1 S DIE=DIC,DA=+Y,DR=".08///ECOMMLLPPRD.FSC.DOMAIN.EXT;400.02///9346;4.5///1" K DIC D ^DIE
K DA,DIE,DR,X,Y
;Set up NIFQRY mail group to trigger batch query for this environment
N DO,DD,DA,DLAYGO,DIC,X,RCSITE
S RCSITE=$G(^XMB("NETNAME")) Q:RCSITE="" ; SITE DOMAIN NAME
S X="S.IBCNH HPID NIF BATCH QUERY@"_RCSITE ; SERVER NAME WITH SITE DOMAIN NAME
S DA(1)=$O(^XMB(3.8,"B","NIFQRY",0)) ; MAIL GROUP IEN
I $D(^XMB(3.8,DA(1),6,"B",$E(X,1,30))) Q ; MAIL ADDRESS ALREADY EXISTS.
S DLAYGO=3.812,DIC(0)="L",DIC="^XMB(3.8,"_DA(1)_",6,"
D FILE^DICN ; FILE THE ADDRESS
;Do not run extract if this patch has already been installed once - DBIA#10141
I $$INSTALDT^XPDUTL("IB*2.0*519")>0 D:'$D(ZTQUEUED) BMES^XPDUTL("Post-Install already performed. No need to run again.") Q
; 08/29/14 No longer run extract in test environments
I IBPRD="T" D:'$D(ZTQUEUED) BMES^XPDUTL("Post-Install extract will not be run in a non-Production environment.") Q
; if the user queued the patch install, just run it for now, skip the tasking prompt
I $D(ZTQUEUED) D TSK Q
; start here if you need to manually run the extract
EXT ;
N IBA,ZTRTN,ZTDESC,ZTSK,ZTIO
S ZTRTN="TSK^IBY519PO",ZTIO="",ZTDESC="Insurance Company Data Extract for NIF Seeding"
S IBA(1)="",IBA(2)=" Tasking Post-Install Insurance Company Data Extract.....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA
D ^%ZTLOAD
; If tasking failed, need to notify someone
I '$D(ZTSK) S IBA(1)="",IBA(2)=" Tasking Data Extract FAILED.....",IBA(3)="" D MES^XPDUTL(.IBA) K IBA Q
S IBA(1)="",IBA(2)=" Task #: "_ZTSK,IBA(3)="" D MES^XPDUTL(.IBA) K IBA
K ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE
Q
;
TSK ; taskman and queued install comes here
N IBN,IBDTA,IBND,IBVID,I,MAXSIZE,COUNT,IBSIZE,IBRTN,IBSTN,DTTM,MSGCNT,IBEOL,TOTREC,IBPRD
K ^TMP("IBY519PO",$J)
; Call to XUPROD allowed by IA#4440
S IBPRD=$S($$PROD^XUPROD(1)=1:"P",1:"T")
S IBSTN=$$SITE^VASITE(),IBSTN=$P(IBSTN,U,3)_U_$P(IBSTN,U,2)
; Set end of line character
S IBEOL="~"
; for testing, set maxsize low - for production Set to 300000
S MAXSIZE=$S(IBPRD="P":300000,1:100000)
; Set record, size and message counters
S COUNT=1,IBSIZE=0,MSGCNT=0,TOTREC=0,IBRTN="IBY519PO",DTTM=$$FMTE^XLFDT($$NOW^XLFDT)
S IBN=0 F S IBN=$O(^DIC(36,IBN)) Q:'IBN D
.; don't print if there are no patients associated with this ins.co. OR if there are no groups associated with this insurance co.
.Q:'$D(^DPT("AB",IBN))
.Q:'$D(^IBA(355.3,"B",IBN))
.S IBDTA(0)=$G(^DIC(36,IBN,0))
.; only active insurance companies
.Q:$P(IBDTA(0),U,5)=1
.F IBND=.11,.13,3,6 S IBDTA(IBND)=$G(^DIC(36,IBN,IBND))
.; Get VA National ID
.S IBVID=$$VID^IBCNHUT1(IBN)
.K DATA
.S COUNT=COUNT+1,TOTREC=TOTREC+1,DATA="INS"_U_$P(IBSTN,U)_U_IBN_U_$P(IBDTA(0),U)
.F I=2,4 S DATA=DATA_U_$P(IBDTA(3),U,I)
.F I=1:1:8 S DATA=DATA_U_$P(IBDTA(6),U,I)
.S DATA=DATA_U_IBVID
.F I=1,2,4 S DATA=DATA_U_$P(IBDTA(.11),U,I)
.S DATA=DATA_U_$P($G(^DIC(5,+$P(IBDTA(.11),U,5),0)),U)
.F I=6,7 S DATA=DATA_U_$P(IBDTA(.11),U,I)
.S DATA=DATA_U_$P(IBDTA(.13),U)_U_$P($G(^IBE(355.2,+$P(IBDTA(0),U,13),0)),U)
.S ^TMP(IBRTN,$J,COUNT)=DATA_U_IBEOL,IBSIZE=IBSIZE+$L(^TMP(IBRTN,$J,COUNT))
.K DATA
.; if we have exceeded max mail message size, start a new one
.I IBSIZE>MAXSIZE D
..D EOF,MAIL(IBRTN,"R")
..K ^TMP(IBRTN,$J)
..S COUNT=1,IBSIZE=0
; send final email if it has records, then cleanup
D EOF I $G(COUNT)>1 D MAIL(IBRTN,"R")
K ^TMP(IBRTN,$J)
; send summary email
S ^TMP("IBSUM",$J,1)=$P(IBSTN,U,2)_" ("_$P(IBSTN,U)_") "_$S(IBPRD="P":"Prod",1:"Test")_" Extract SUMMARY Complete Date/Time: "_$$FMTE^XLFDT($$NOW^XLFDT)
S ^TMP("IBSUM",$J,2)=""
S ^TMP("IBSUM",$J,MSGCNT+3)="==============================================================================="
S ^TMP("IBSUM",$J,MSGCNT+4)="Total Record Count: "_TOTREC
D MAIL("IBSUM","S")
K IBN,IBDTA,IBND,IBVID,I,MAXSIZE,COUNT,IBSIZE,IBRTN,IBSTN,DTTM,MSGCNT,IBEOL,TOTREC,XMTEXT,IBPRD
Q
;
EOF ; end one message
Q:COUNT=1
S MSGCNT=MSGCNT+1
S ^TMP(IBRTN,$J,1)="HDR"_U_IBSTN_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_IBRTN_U_IBPRD_U_IBEOL
S ^TMP("IBSUM",$J,MSGCNT+2)="Message Number: "_MSGCNT_" Line Count: "_$J(COUNT,6)_" Sent at: "_$$FMTE^XLFDT($$NOW^XLFDT)
S COUNT=COUNT+1
S ^TMP(IBRTN,$J,COUNT)="EOF"_U_IBSTN_U_IBEOL
Q
;
MAIL(NODE,TYP) ; email message
N XMSUB,XMZ,XMMG,DIFROM,XMEXT,XMY
; this is the mail group to send the extract to in Production
I IBPRD="P" S:TYP="S" XMY("VHACBONIFINSExtract@domain.ext")=""
I IBPRD="P" S:TYP'="S" XMY("XXX@Q-NPS.DOMAIN.EXT")=""
; for testing, send to these email addresses
I IBPRD="T" S XMY("GRACE.FIAMENGO@DOMAIN.EXT")="",XMY("FIAMENGO,GRACE")="",XMY("CHRISTOPHER.THAYER@DOMAIN.EXT")="",XMY("THAYER,CHRISTOPHER")=""
S XMTEXT="^TMP("""_NODE_""","_$J_","
S XMSUB=$P(IBSTN,U,2)_" ("_$P(IBSTN,U)_") "_$S(IBPRD="P":"Prod",1:"Test")_" Extract "_$S(TYP="R":"Run Date/Time: "_DTTM,1:"Complete at: "_$$FMTE^XLFDT($$NOW^XLFDT))
D ^XMD
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY519PO 7569 printed Nov 22, 2024@17:44:27 Page 2
IBY519PO ;ALB/GEF - Post install routine for patch 519 ; 21-FEB-14
+1 ;;2.0;INTEGRATED BILLING;**519**;21-MAR-94;Build 56
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Call to XUPROD is allowed with IA#4440
+5 ; XPDUTL calls are DBIA#10141
+6 ; ZTQUEUED is a KIDS variable that indicates if the user queued the install. This variable should not
+7 ; be killed or newed here
+8 ;
+9 DO EN
+10 QUIT
DOC ; This routine will Create Data Extract EMAILS from Each VAMC to FSC for Initial Seeding of NIF
+1 ;
+2 ; Each VistA site will submit a data extract in the form of one or more emails as defined in
+3 ; the ICD. This data extract is to happen only once at each of the VAMC after the patch
+4 ; IB*2.0*519 is nationally released upon direction of the VA's Chief Business Office's (CBO)
+5 ; eInsurance team. FSC will load the data from these flat files into the FSC Staging table.
+6 ; The data within the FSC Staging table will be used to identify a consolidated list of payers
+7 ;(insurance companies) across all VAMCs which will then be used to initially populated (seed)
+8 ; the VA National Insurance File (NIF).
+9 ;
+10 ; Types of Records: HEADER (HDR), PAYER (INS), TRAILER (EOF)
+11 ; * Each VAMC will have 1 HEADER record and 1 TRAILER record, with 1 to many PAYER records in between the two.
+12 ; Delimiter = "^"
+13 ;
+14 ; Data output:
+15 ; HDR^Station #^Site name
+16 ; INS^Stn#^Ins.Co.ien^NAME^EDI PROF^EDI INST^QUAL^2NDARY I1^QUAL^2ND I2^QUAL^2ND P1^QUAL^2ND P2^VA NTL ID^STR ADR 1^ADR2^CITY^ST^ZIP^BILL NM^PH^TYP OF COVG
+17 ; EOF^Stn#^Site
+18 ;
+19 ; Search criteria:
+20 ; 1. Insurance Company entry in file #36 must be ACTIVE (field #.05 '=1)
+21 ; 2. There must be patients associated with the Ins.Co. (^DPT("AB",INS))
+22 ; 3. There must be groups associated with the Ins. Co. (^IBA(355.3,"B",INS))
+23 ;
+24 ; note the following:
+25 ; 3.1 PAYER (*P365.12'), [3;10] populate with VA NATIONAL ID only if
+26 ; Payer file #365.13 application "IIV" is locally & nationally active
+27 ;
+28 QUIT
EN ; Post Install Routine primary entry point
+1 ;
+2 NEW IBPRD,DIC,X,Y,DIE,DR,DA
+3 ; Call to XUPROD allowed by IA#4440
+4 SET IBPRD=$SELECT($$PROD^XUPROD(1)=1:"P",1:"T")
+5 ;Stuff FSC domain into link
+6 SET DIC="^HLCS(870,"
SET DIC(0)="LS"
SET X="IB NIF TCP"
DO ^DIC
+7 ; For test environments, use the FSC test domain
+8 IF IBPRD="T"
IF Y'=-1
SET DIE=DIC
SET DA=+Y
SET DR=".08///ECOMMLLPTST.FSC.DOMAIN.EXT;400.02///9346;4.5///1"
KILL DIC
DO ^DIE
+9 ; For Production environments, use the FSC PRD domain
+10 IF IBPRD="P"
IF Y'=-1
SET DIE=DIC
SET DA=+Y
SET DR=".08///ECOMMLLPPRD.FSC.DOMAIN.EXT;400.02///9346;4.5///1"
KILL DIC
DO ^DIE
+11 KILL DA,DIE,DR,X,Y
+12 ;Set up NIFQRY mail group to trigger batch query for this environment
+13 NEW DO,DD,DA,DLAYGO,DIC,X,RCSITE
+14 ; SITE DOMAIN NAME
SET RCSITE=$GET(^XMB("NETNAME"))
if RCSITE=""
QUIT
+15 ; SERVER NAME WITH SITE DOMAIN NAME
SET X="S.IBCNH HPID NIF BATCH QUERY@"_RCSITE
+16 ; MAIL GROUP IEN
SET DA(1)=$ORDER(^XMB(3.8,"B","NIFQRY",0))
+17 ; MAIL ADDRESS ALREADY EXISTS.
IF $DATA(^XMB(3.8,DA(1),6,"B",$EXTRACT(X,1,30)))
QUIT
+18 SET DLAYGO=3.812
SET DIC(0)="L"
SET DIC="^XMB(3.8,"_DA(1)_",6,"
+19 ; FILE THE ADDRESS
DO FILE^DICN
+20 ;Do not run extract if this patch has already been installed once - DBIA#10141
+21 IF $$INSTALDT^XPDUTL("IB*2.0*519")>0
if '$DATA(ZTQUEUED)
DO BMES^XPDUTL("Post-Install already performed. No need to run again.")
QUIT
+22 ; 08/29/14 No longer run extract in test environments
+23 IF IBPRD="T"
if '$DATA(ZTQUEUED)
DO BMES^XPDUTL("Post-Install extract will not be run in a non-Production environment.")
QUIT
+24 ; if the user queued the patch install, just run it for now, skip the tasking prompt
+25 IF $DATA(ZTQUEUED)
DO TSK
QUIT
+26 ; start here if you need to manually run the extract
EXT ;
+1 NEW IBA,ZTRTN,ZTDESC,ZTSK,ZTIO
+2 SET ZTRTN="TSK^IBY519PO"
SET ZTIO=""
SET ZTDESC="Insurance Company Data Extract for NIF Seeding"
+3 SET IBA(1)=""
SET IBA(2)=" Tasking Post-Install Insurance Company Data Extract....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+4 DO ^%ZTLOAD
+5 ; If tasking failed, need to notify someone
+6 IF '$DATA(ZTSK)
SET IBA(1)=""
SET IBA(2)=" Tasking Data Extract FAILED....."
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
QUIT
+7 SET IBA(1)=""
SET IBA(2)=" Task #: "_ZTSK
SET IBA(3)=""
DO MES^XPDUTL(.IBA)
KILL IBA
+8 KILL ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE
+9 QUIT
+10 ;
TSK ; taskman and queued install comes here
+1 NEW IBN,IBDTA,IBND,IBVID,I,MAXSIZE,COUNT,IBSIZE,IBRTN,IBSTN,DTTM,MSGCNT,IBEOL,TOTREC,IBPRD
+2 KILL ^TMP("IBY519PO",$JOB)
+3 ; Call to XUPROD allowed by IA#4440
+4 SET IBPRD=$SELECT($$PROD^XUPROD(1)=1:"P",1:"T")
+5 SET IBSTN=$$SITE^VASITE()
SET IBSTN=$PIECE(IBSTN,U,3)_U_$PIECE(IBSTN,U,2)
+6 ; Set end of line character
+7 SET IBEOL="~"
+8 ; for testing, set maxsize low - for production Set to 300000
+9 SET MAXSIZE=$SELECT(IBPRD="P":300000,1:100000)
+10 ; Set record, size and message counters
+11 SET COUNT=1
SET IBSIZE=0
SET MSGCNT=0
SET TOTREC=0
SET IBRTN="IBY519PO"
SET DTTM=$$FMTE^XLFDT($$NOW^XLFDT)
+12 SET IBN=0
FOR
SET IBN=$ORDER(^DIC(36,IBN))
if 'IBN
QUIT
Begin DoDot:1
+13 ; don't print if there are no patients associated with this ins.co. OR if there are no groups associated with this insurance co.
+14 if '$DATA(^DPT("AB",IBN))
QUIT
+15 if '$DATA(^IBA(355.3,"B",IBN))
QUIT
+16 SET IBDTA(0)=$GET(^DIC(36,IBN,0))
+17 ; only active insurance companies
+18 if $PIECE(IBDTA(0),U,5)=1
QUIT
+19 FOR IBND=.11,.13,3,6
SET IBDTA(IBND)=$GET(^DIC(36,IBN,IBND))
+20 ; Get VA National ID
+21 SET IBVID=$$VID^IBCNHUT1(IBN)
+22 KILL DATA
+23 SET COUNT=COUNT+1
SET TOTREC=TOTREC+1
SET DATA="INS"_U_$PIECE(IBSTN,U)_U_IBN_U_$PIECE(IBDTA(0),U)
+24 FOR I=2,4
SET DATA=DATA_U_$PIECE(IBDTA(3),U,I)
+25 FOR I=1:1:8
SET DATA=DATA_U_$PIECE(IBDTA(6),U,I)
+26 SET DATA=DATA_U_IBVID
+27 FOR I=1,2,4
SET DATA=DATA_U_$PIECE(IBDTA(.11),U,I)
+28 SET DATA=DATA_U_$PIECE($GET(^DIC(5,+$PIECE(IBDTA(.11),U,5),0)),U)
+29 FOR I=6,7
SET DATA=DATA_U_$PIECE(IBDTA(.11),U,I)
+30 SET DATA=DATA_U_$PIECE(IBDTA(.13),U)_U_$PIECE($GET(^IBE(355.2,+$PIECE(IBDTA(0),U,13),0)),U)
+31 SET ^TMP(IBRTN,$JOB,COUNT)=DATA_U_IBEOL
SET IBSIZE=IBSIZE+$LENGTH(^TMP(IBRTN,$JOB,COUNT))
+32 KILL DATA
+33 ; if we have exceeded max mail message size, start a new one
+34 IF IBSIZE>MAXSIZE
Begin DoDot:2
+35 DO EOF
DO MAIL(IBRTN,"R")
+36 KILL ^TMP(IBRTN,$JOB)
+37 SET COUNT=1
SET IBSIZE=0
End DoDot:2
End DoDot:1
+38 ; send final email if it has records, then cleanup
+39 DO EOF
IF $GET(COUNT)>1
DO MAIL(IBRTN,"R")
+40 KILL ^TMP(IBRTN,$JOB)
+41 ; send summary email
+42 SET ^TMP("IBSUM",$JOB,1)=$PIECE(IBSTN,U,2)_" ("_$PIECE(IBSTN,U)_") "_$SELECT(IBPRD="P":"Prod",1:"Test")_" Extract SUMMARY Complete Date/Time: "_$$FMTE^XLFDT($$NOW^XLFDT)
+43 SET ^TMP("IBSUM",$JOB,2)=""
+44 SET ^TMP("IBSUM",$JOB,MSGCNT+3)="==============================================================================="
+45 SET ^TMP("IBSUM",$JOB,MSGCNT+4)="Total Record Count: "_TOTREC
+46 DO MAIL("IBSUM","S")
+47 KILL IBN,IBDTA,IBND,IBVID,I,MAXSIZE,COUNT,IBSIZE,IBRTN,IBSTN,DTTM,MSGCNT,IBEOL,TOTREC,XMTEXT,IBPRD
+48 QUIT
+49 ;
EOF ; end one message
+1 if COUNT=1
QUIT
+2 SET MSGCNT=MSGCNT+1
+3 SET ^TMP(IBRTN,$JOB,1)="HDR"_U_IBSTN_U_"Message Number: "_MSGCNT_U_"Line Count: "_COUNT_U_DTTM_U_IBRTN_U_IBPRD_U_IBEOL
+4 SET ^TMP("IBSUM",$JOB,MSGCNT+2)="Message Number: "_MSGCNT_" Line Count: "_$JUSTIFY(COUNT,6)_" Sent at: "_$$FMTE^XLFDT($$NOW^XLFDT)
+5 SET COUNT=COUNT+1
+6 SET ^TMP(IBRTN,$JOB,COUNT)="EOF"_U_IBSTN_U_IBEOL
+7 QUIT
+8 ;
MAIL(NODE,TYP) ; email message
+1 NEW XMSUB,XMZ,XMMG,DIFROM,XMEXT,XMY
+2 ; this is the mail group to send the extract to in Production
+3 IF IBPRD="P"
if TYP="S"
SET XMY("VHACBONIFINSExtract@domain.ext")=""
+4 IF IBPRD="P"
if TYP'="S"
SET XMY("XXX@Q-NPS.DOMAIN.EXT")=""
+5 ; for testing, send to these email addresses
+6 IF IBPRD="T"
SET XMY("GRACE.FIAMENGO@DOMAIN.EXT")=""
SET XMY("FIAMENGO,GRACE")=""
SET XMY("CHRISTOPHER.THAYER@DOMAIN.EXT")=""
SET XMY("THAYER,CHRISTOPHER")=""
+7 SET XMTEXT="^TMP("""_NODE_""","_$JOB_","
+8 SET XMSUB=$PIECE(IBSTN,U,2)_" ("_$PIECE(IBSTN,U)_") "_$SELECT(IBPRD="P":"Prod",1:"Test")_" Extract "_$SELECT(TYP="R":"Run Date/Time: "_DTTM,1:"Complete at: "_$$FMTE^XLFDT($$NOW^XLFDT))
+9 DO ^XMD
+10 QUIT
+11 ;
