IBCNHUT2 ;ALB/GEF - HPID/OEID UTILITIES ;11-MAR-14
;;2.0;INTEGRATED BILLING;**519,549**;21-MAR-94;Build 54
;;Per VA Directive 6402, this routine should not be modified.
;
; this routine contains HL7 utilities for the HPID project.
Q
;
PUR ;
; This section handles the purging of the HPID/OEID data stored in the
; HPID/OEID Transmission Queue file (#367.1) and in the HPID/OEID Response file (#367).
; This is called from a nightly tasked routine IBAMTC. Data created within the last 2 weeks
; cannot be purged. Only requested data that has a NIF-ID response received will be purged.
; Unsolicited responses will also be purged as will those with a status of EXR (Exception
; Report Reject), whether they have a NIF ID or not.
; The system will not purge entries with no response, entries that have dropped to
; an exception queue, or entries with a response less than 14 days old.
; Uses this x-ref on file 367: ^IBCNH(367,"E",future purge date/time,ien)=""
; and finds the corresponding entry in file 367.1 with: ^IBCNH(367,ien,0)=2nd piece is ien in 367.1
;
; IB*2.0*549 - This segment also verifies that the HL7 logical link is up and running properly
;
N ENDDT,TQIEN,RSIEN,DA,DIK,RDTA,STDT,RST,TST,ID,RTYP
S ENDDT=$$FMADD^XLFDT(DT,-15)
S STDT="" F S STDT=$O(^IBCNH(367,"E",STDT)) Q:STDT=""!($P(STDT,".",1)>ENDDT) D
.S RSIEN="" F S RSIEN=$O(^IBCNH(367,"E",STDT,RSIEN)) Q:RSIEN="" D
..; double check to make sure they are both correct status with status R having a NIF ID before deleting
..S RDTA=$G(^IBCNH(367,RSIEN,0))
..S RST=$P(RDTA,U,5),RTYP=$P(RDTA,U,3)
..I $E(RST)'="R"&(RST'="EXR") Q
..; as of 6/23/14, do not purge EXR
..Q:RST="EXR"
..S TQIEN=$P(RDTA,U,2)
..I TQIEN'="" S TST=$P($G(^IBCNH(367.1,TQIEN,0)),U,4) I $E(TST)'="R" Q
..; if this is a requested response, make sure we got a NIF
..I RTYP="R",RST="R" Q:'$D(^IBCNH(367,"D",8,RSIEN))
..I RTYP="R",RST="R" S ID=$O(^IBCNH(367,"D",8,RSIEN,"")) Q:$P($G(^IBCNH(367,RSIEN,1,ID,0)),U,2)=""
..; OK TO DELETE
..S DA=RSIEN,DIK="^IBCNH(367," D ^DIK
..Q:TQIEN=""
..S DA=TQIEN,DIK="^IBCNH(367.1," D ^DIK
;
K ENDDT,TQIEN,RSIEN,DA,DIK,RDTA,STDT,ID,RTYP
;
; IB*2.0*549 Set up for verifying logical link
D SETUPVER
Q
;
EXT ; kick off HL7 queries of each insurance company sent to the NIF for the initial HPID extract
; called from option IBCNH HPID NIF BATCH QUERY. To be run once FSC notifies site that they are
; ready - ie. they have received and processed the data extracts and have the NIF ID's for each
; insurance company.
;
N IBN,DIE,DA,DR,C
; activate HPID/OEID flag in IB SITE PARAMS
S DIE="^IBE(350.9,",DA=$P($G(^IBE(350.9,0)),U,3),DR=70.01_"///"_1 D ^DIE
S IBN=0,C=0 F S IBN=$O(^DIC(36,IBN)) Q:'IBN D
.; update display with status
.S C=C+1 I C#20 W "."
.; don't send if we already have a pending message for this insurance company
.Q:$D(^IBCNH(367.1,"INS",IBN))
.; don't send if we already have a NIF ID for this insurance company
.Q:$$NIF^IBCNHUT1(IBN)
.; don't send 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))
.; only active insurance companies
.Q:$P($G(^DIC(36,IBN,0)),U,5)=1
.; from here we can kick off the HL7 message.
.D SEND^IBCNHHLO(IBN)
K IBN,DIE,DA,DR,C
Q
;
FM36(INS,DATA,TQN) ; updates file 36, 8 node with data received from the NIF
; INS = insurance company ien (REQUIRED)
; DATA=String containing HPID data in this format: HPID^CHP/SHP^PARENT^NIF ID
; NIF = NIF ID for insurance company
; TQN=ien of entry in file 367.1 (if data came from a requested response)
; returns "-1^Error code^Error reason" if entry not added and Processing Status if added/updated
;
N DIC,DR,DA,DIE,I,X
Q:INS="" "-1^ED^DATABASE Error: Not a valid Insurance Company ien!"
; validate Vista Unique ID and HPID data format
Q:'$D(^DIC(36,INS)) "-1^ED^Error: Insurance ien does NOT exist at this site!"
; don't update insurance file if Legacy ID's have changed since we sent the request
Q:$$LEG($G(TQN),INS) "-1^EL^LEGACY ID Error: Legacy ID Changed!"
; ready to update file 36, fields 8.01, 8.02, 8.03 and 8.04 with DATA
S DIE="^DIC(36,",DA=INS,DR="" K DIC
F I=2:1:4 S DR=DR_"8.0"_I_"///^S X=$P(DATA,U,"_I_");"
D ^DIE
; add HPID separately since if it fails input transform nothing else updates
S DR="8.01///^S X=$P(DATA,U)" D ^DIE
K DIE,DR,I,INS,X,LID,DIC
Q DA_"^R^RESPONSE PROCESSED: File 36 Updated"
;
FM71(INS,HLID) ; adds entry to file 367.1 (HPID/OEID TRANSMISSION QUEUE) and file 367 (HPID/OEID RESPONSE)
; INS =insurance company ien (required)
; HLID = message control ID number assigned by HL7 when HL7 message was created (required)
; returns ien of entry added to file 367.1
;
N DIC,DR,DA,DIE,Y,IDN,DATA,TQN,RSN,X,DLAYGO
Q:INS="" "-1^Error: Not a valid Insurance Company ien!"
Q:HLID="" "-1^Error: No HL7 Control Number defined!"
S DIC="^IBCNH(367.1,",DIC(0)="LS",X=$P($G(^IBCNH(367.1,0)),U,3)+1,DLAYGO=367.1 D ^DIC
Q:Y=-1 "-1^Error: HPID QUEUE entry NOT added!"
S TQN=+Y
; add stub record in file 367
S DIC="^IBCNH(367,",DIC(0)="LS",X=HLID,DLAYGO=367 D ^DIC
; update 367 with additional fields.
S RSN=+Y
I Y>0 S DIE=DIC,DA=+Y,DR=".01///"_HLID_";.02///"_TQN_";.03///R" K DIC D ^DIE
; now update new 367.1 entry with insurance company data fields on 2 node, response info and status of A for AWAITING RESPONSE
Q:'$$R36(INS,.DATA)
S DIE="^IBCNH(367.1,",DA=TQN,DR="" K DIC
S DR=".02///"_INS_";"_".04///"_"A"_";.07///"_RSN
F I=1:1:8 S DR=DR_";2.0"_I_"///^S X=$P(DATA(1),U,"_I_")"
D ^DIE
; update ID multiple with ID data
F IDN=1:1:10 I $P($G(DATA(2)),U,IDN)'="" D
.; create ID multiple
.S DIC="^IBCNH(367.1,"_TQN_",1,",DA(1)=TQN,DIC(0)="LS" S X="`"_IDN,DLAYGO=367.1 D ^DIC Q:Y=-1
.; add ID data to new multiple entry
.S DIE=DIC,DA=+Y,DR=".01///"_IDN_";.02///^S X=$P($G(DATA(2)),U,"_IDN_");.03///"_$P($G(DATA(3)),U,IDN) K DIC
.D ^DIE
K DIC,DR,DA,DIE,Y,IDN,DATA,RSN,X,DLAYGO
Q TQN
;
FM367(IEN,DATA,ID,QL) ; updates entry to file 367 (HPID/OEID RESPONSE) for requested responses,
; or creates a new entry for unsolicited responses.
; IEN = ien of existing entry in file 367 (will only exist for requested responses)
; DATA = data string containing response data for 0 node (NOTE: You do not have to pass all this data, but it must be in this format):
; HLID^TQN^RTY^INS NAME^NPS^STAT D/T^UID^PARENT HPID^CHP or SHP
; TQN = Transaction ien in file 367.1 (HPID/OEID TRANSMISSION QUEUE), null for unsolicited responses
; RTY = Response Type: R for Requested or U for Unsolicited
; NPS = Processing status at NIF, either R for Response Processed or X for Exception Report or EXR for Rejected
; HLID = control ID of HL7 message (required if this is an unsolicited response, not req'd if you have ien)
; ID = Data string of ID data sent from NIF. MUST BE in this format:
;(ie. HPID must always be 9th piece, NIF must be 8, If no EDI numbers received, those pieces will be null, etc.):
; EDI ID NUMBER-PROF^EDI ID NUMBER-INST^EDI PROF SECONDARY ID(1)^EDI PROF SECONDARY ID(2)^EDI INST SECONDARY ID(1)^EDI INST SECONDARY ID(2)^VA NATIONAL ID^NIF ID^HPID/OEID^VISTA UNIQUE ID
; QL=string of secondary ID qualifiers, in this format: ^^QUAL1(PS1)^QUAL2(PS2)^QAUL3(IS1)^QUAL4(IS2)
; RETURNS: IEN of file 367 entry that was updated, or -1 for error condition
;
N DIC,DR,DA,DIE,Y,IDN,HLID,RTY,INS,TQN,PS,NPS,DLAYGO
S DATA=$G(DATA),ID=$G(ID),QL=$G(QL)
S HLID=$P($G(DATA),U),RTY=$P($G(DATA),U,3)
I RTY="R",$G(IEN)="" Q "-1^Error: No HPID/OEID Response ien!"
I $G(IEN)="",$G(HLID)="" Q "-1^Error: No HPID/OEID Response and no HL7 ien!"
; if NIF processing status is not R, update response status only and quit
Q:$P(DATA,U,5)'="R" $$STAT^IBCNHUT1(IEN,$P(DATA,U,5))
; create new entry in 367 for unsolicited responses and update file 36 using NIF ID
I RTY="U" S IEN=$$UNSOL^IBCNHUT1(HLID,RTY,ID,DATA)
Q:$P(IEN,U)=-1 "-1^Error: HPID RESPONSE entry NOT added!"
; create and update ID multiple
F IDN=1:1:10 I $P(ID,U,IDN)'="" D
.S DIC="^IBCNH(367,"_IEN_",1,",DA(1)=IEN,DIC(0)="LS",X="`"_IDN,DLAYGO=367 D ^DIC Q:Y=-1
.S DIE=DIC,DA=+Y,DR=".01///"_IDN_";.02///^S X=$P(ID,U,"_IDN_");.03///"_$P(QL,U,IDN) K DIC
.D ^DIE
; update 367 with additional fields.
S DIE="^IBCNH(367,",DA=IEN,DR=""
F I=3,4,7,8,9 S DR=DR_".0"_I_"///^S X=$P(DATA,U,"_I_");"
D ^DIE
; now update the insurance company entry in file 36 for requested responses. Use the insurance
; ien that was sent in the original request.
; Unsolicited response are updated via previous call to $$UNSOL^IBCNHUT1
Q:RTY="U" IEN
S INS="",TQN=$P($G(^IBCNH(367,IEN,0)),U,2) S:TQN'="" INS=$P(^IBCNH(367.1,TQN,0),U,2)
S PS=$$FM36(INS,$P(ID,U,9)_U_$P(DATA,U,9)_U_$P(DATA,U,8)_U_$P(ID,U,8),TQN)
; update field .05 in file 367 (PROCESSING STATUS)
Q $$STAT^IBCNHUT1(IEN,$P(PS,U,2))
;
R36(INS,DATA) ; this function gathers all the insurance company data we need to send to the NIF
; INS= ien of insurance company entry (required)
; DATA=name of array to store data results in
; Returns: DATA(0) = Insurance Ien^Insurance Company Name^INACTIVE FLAG^UID^NIF ID^HPID/OEID^CHP/SHP^PARENT HPID
; DATA(1) = STREET ADDRESS 1^STR AD2^CITY^STATE^ZIP^BILLING CO NAME^TYPE OF COVERAGE^PHONE#
; DATA(2) = string of ID's in this format:
; EDI ID NUMBER-PROF^EDI ID NUMBER-INST^EDI PROF SECONDARY ID(1)^EDI PROF SECONDARY ID(2)^EDI INST SECONDARY ID(1)^EDI INST SECONDARY ID(2)^VA NATIONAL ID^NIF ID^HPID/OEID^VISTA UNIQUE ID
; DATA(3) = string of ID qualifiers in this format: ^^QUAL1(PS1)^QUAL2(PS2)^QAUL3(IS1)^QUAL4(IS2)
;
N ID,QL,I,ND
F I=0:1:3 S DATA(I)=""
S ND(.11)=$G(^DIC(36,INS,.11)),ND(0)=$G(^DIC(36,INS,0))
F I=1,2,4:1:7 S DATA(1)=DATA(1)_$P(ND(.11),U,I)_U
S DATA(1)=DATA(1)_$P(ND(0),U,13)_U_$P($G(^DIC(36,INS,.13)),U)
S ID(7)=$$VID^IBCNHUT1(INS),ND(6)=$G(^DIC(36,INS,6)),ND(3)=$G(^DIC(36,INS,3))
S ID(3)=$P(ND(6),U,6),ID(4)=$P(ND(6),U,8),ID(5)=$P(ND(6),U,2),ID(6)=$P(ND(6),U,4)
S QL(3)=$P(ND(6),U,5),QL(4)=$P(ND(6),U,7),QL(5)=$P(ND(6),U),QL(6)=$P(ND(6),U,3)
S ID(1)=$P(ND(3),U,2),ID(2)=$P(ND(3),U,4),ID(10)=$$UID^IBCNHUT1(INS)
S DATA(0)=INS_U_$P(ND(0),U)_U_$P(ND(0),U,5)_U_$$UID^IBCNHUT1(INS)_U_$$NIF^IBCNHUT1(INS)_U_$$HPD^IBCNHUT1(INS)_U_$$SHP^IBCNHUT1(INS)_U_$$PHP^IBCNHUT1(INS)
S ID(8)=$P(DATA(0),U,5),ID(9)=$P(DATA(0),U,6)
F I=1:1:10 S DATA(2)=DATA(2)_$G(ID(I))_U
F I=1:1:6 S DATA(3)=DATA(3)_$G(QL(I))_U
K ID,QL,I,ND
Q 1
;
SETUPVER ; Set up verifying of IB NIF TCP logical link
; IB*2.0*549 added method
;
N CURRTIME,MTIME
N DIFROM,LLIEN,NIFTM,XMDUN,XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,XX,YY,ZTRTN,ZTDESC
N ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
;
I '$$PROD^XUPROD(1) G SETUPVRX ; Only check for stuck messages in production
;
S NIFTM=$$GET1^DIQ(350.9,"1,",51.29,"I") ; Get IB NIF TCP data
I NIFTM="" G SETUPVRX ; MM message time is not defined
S LLIEN=$O(^HLCS(870,"B","IB NIF TCP","")) ; IB NIF TCP Logical Link
I LLIEN="" G SETUPVRX
;
S CURRTIME=$P($H,",",2) ; current $H time
S MTIME=DT_"."_NIFTM ; build a FileMan date/time
S MTIME=$$FMTH^XLFDT(MTIME) ; convert to $H format
S MTIME=$P(MTIME,",",2) ; $H time of MM message
;
; If the current time is after the MailMan message time, then schedule the message for tomorrow at that time.
; Otherwise, schedule it for later today.
S ZTDTH=$S(CURRTIME>MTIME:$H+1,1:+$H)_","_MTIME
;
; Set up the other TaskManager variables
S ZTRTN="VERFYLNK^IBCNHUT2" ; The tag that we want TASKMAN to call
S ZTDESC="Verify HL7 Logical link 'IB NIF TCP' is running"
S ZTIO=""
S ZTSAVE("LLIEN")=""
S ZTSAVE("NIFTM")=""
D ^%ZTLOAD ; Call TaskManager
I '$G(ZTSK) D ; Task # is not okay
. ;
. ; Send a MailMan message if this Task could not get scheduled
. S MGRP="VHAeInsuranceRapidResponse@domain.ext"
. ;
. S XMSUB=" Daily verification of IB NIF TCP link Not Scheduled"
. S XMTEXT="XMTEXT("
. S XMTEXT(1)="TaskManager could not schedule the daily verification of IB NIF TCP link"
. S XMTEXT(2)="at the specified time of "_$E(NIFTM,1,2)_":"_$E(NIFTM,3,4)_"."
. D ^XMD
;
SETUPVRX ;
Q
;
VERFYLNK ; Verify IB NIF TCP entry in the HL Logical Link file (#870) on a daily basis
; IB*2.0*549 added Method
; Input - LLIEN [thru ZTSAVE("LLIEN")]
; NIFTM [thru ZTSAVE("NIFTM")]
;
N FLG,IEN,X,XMSUB,XMTEXT,XMY,XX,YY
S IEN=$O(^HLMA("AC","O",LLIEN,""))
I IEN="" S FLG=1
E D
. H 30
. S FLG=$S('$D(^HLMA("AC","O",LLIEN,IEN)):1,1:0) ; Processing observed / No processing
;
I 'FLG D ; Link is apparently not processing records
. S XX=$$SITE^VASITE()
. S YY=$P(XX,"^",2)_"(#"_$P(XX,"^",1)_")"
. S X="No activity seen in link"
. ;
. ; Send a MailMan message if link is not processing records
. S XMY("VHAeInsuranceRapidResponse@domain.ext")=""
. S XMY(.5)=""
. ;
. S XMSUB=" Daily verification of IB NIF TCP link: "_X
. S XMTEXT="XMTEXT("
. S XMTEXT(1)="Daily verification of IB NIF TCP was unsuccessful ("_X_")"
. S XMTEXT(2)="at the specified time of "_$E(NIFTM,1,2)_":"_$E(NIFTM,3,4)_" for site: "_YY_"."
. D ^XMD
Q
;
LEG(TQN,INS) ; function to determine if legacy ID's changed since we sent them out
; returns a 0 if Legacy ID has not changed and a "1^EL^Error: Legacy ID Changed!" if it has.
;
N N,TID,I
Q:TQN="" 0
Q:INS="" 0
F I=1,2 D
.S N=$O(^IBCNH(367.1,TQN,1,"B",I,"")) Q:N=""
.S TID(I)=$P($G(^IBCNH(367.1,TQN,1,N,0)),U,2)
Q:$G(TID(1))'=$P($G(^DIC(36,INS,3)),U,2) "1^EL^Error: Legacy ID Changed!"
Q:$G(TID(2))'=$P($G(^DIC(36,INS,3)),U,4) "1^EL^Error: Legacy ID Changed!"
K N,TID,I
Q 0
;
SMAIL(MGRP,XMSUB,MSG) ; Summary email
; IB*2.0*549 Send e-mail
N DIFROM,XMDUN,XMDUZ,XMMG,XMTEXT,XMY,XMZ
S XMY(MGRP)=""
S XMTEXT=MSG
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNHUT2 14085 printed Dec 13, 2024@02:15:50 Page 2
IBCNHUT2 ;ALB/GEF - HPID/OEID UTILITIES ;11-MAR-14
+1 ;;2.0;INTEGRATED BILLING;**519,549**;21-MAR-94;Build 54
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; this routine contains HL7 utilities for the HPID project.
+5 QUIT
+6 ;
PUR ;
+1 ; This section handles the purging of the HPID/OEID data stored in the
+2 ; HPID/OEID Transmission Queue file (#367.1) and in the HPID/OEID Response file (#367).
+3 ; This is called from a nightly tasked routine IBAMTC. Data created within the last 2 weeks
+4 ; cannot be purged. Only requested data that has a NIF-ID response received will be purged.
+5 ; Unsolicited responses will also be purged as will those with a status of EXR (Exception
+6 ; Report Reject), whether they have a NIF ID or not.
+7 ; The system will not purge entries with no response, entries that have dropped to
+8 ; an exception queue, or entries with a response less than 14 days old.
+9 ; Uses this x-ref on file 367: ^IBCNH(367,"E",future purge date/time,ien)=""
+10 ; and finds the corresponding entry in file 367.1 with: ^IBCNH(367,ien,0)=2nd piece is ien in 367.1
+11 ;
+12 ; IB*2.0*549 - This segment also verifies that the HL7 logical link is up and running properly
+13 ;
+14 NEW ENDDT,TQIEN,RSIEN,DA,DIK,RDTA,STDT,RST,TST,ID,RTYP
+15 SET ENDDT=$$FMADD^XLFDT(DT,-15)
+16 SET STDT=""
FOR
SET STDT=$ORDER(^IBCNH(367,"E",STDT))
if STDT=""!($PIECE(STDT,".",1)>ENDDT)
QUIT
Begin DoDot:1
+17 SET RSIEN=""
FOR
SET RSIEN=$ORDER(^IBCNH(367,"E",STDT,RSIEN))
if RSIEN=""
QUIT
Begin DoDot:2
+18 ; double check to make sure they are both correct status with status R having a NIF ID before deleting
+19 SET RDTA=$GET(^IBCNH(367,RSIEN,0))
+20 SET RST=$PIECE(RDTA,U,5)
SET RTYP=$PIECE(RDTA,U,3)
+21 IF $EXTRACT(RST)'="R"&(RST'="EXR")
QUIT
+22 ; as of 6/23/14, do not purge EXR
+23 if RST="EXR"
QUIT
+24 SET TQIEN=$PIECE(RDTA,U,2)
+25 IF TQIEN'=""
SET TST=$PIECE($GET(^IBCNH(367.1,TQIEN,0)),U,4)
IF $EXTRACT(TST)'="R"
QUIT
+26 ; if this is a requested response, make sure we got a NIF
+27 IF RTYP="R"
IF RST="R"
if '$DATA(^IBCNH(367,"D",8,RSIEN))
QUIT
+28 IF RTYP="R"
IF RST="R"
SET ID=$ORDER(^IBCNH(367,"D",8,RSIEN,""))
if $PIECE($GET(^IBCNH(367,RSIEN,1,ID,0)),U,2)=""
QUIT
+29 ; OK TO DELETE
+30 SET DA=RSIEN
SET DIK="^IBCNH(367,"
DO ^DIK
+31 if TQIEN=""
QUIT
+32 SET DA=TQIEN
SET DIK="^IBCNH(367.1,"
DO ^DIK
End DoDot:2
End DoDot:1
+33 ;
+34 KILL ENDDT,TQIEN,RSIEN,DA,DIK,RDTA,STDT,ID,RTYP
+35 ;
+36 ; IB*2.0*549 Set up for verifying logical link
+37 DO SETUPVER
+38 QUIT
+39 ;
EXT ; kick off HL7 queries of each insurance company sent to the NIF for the initial HPID extract
+1 ; called from option IBCNH HPID NIF BATCH QUERY. To be run once FSC notifies site that they are
+2 ; ready - ie. they have received and processed the data extracts and have the NIF ID's for each
+3 ; insurance company.
+4 ;
+5 NEW IBN,DIE,DA,DR,C
+6 ; activate HPID/OEID flag in IB SITE PARAMS
+7 SET DIE="^IBE(350.9,"
SET DA=$PIECE($GET(^IBE(350.9,0)),U,3)
SET DR=70.01_"///"_1
DO ^DIE
+8 SET IBN=0
SET C=0
FOR
SET IBN=$ORDER(^DIC(36,IBN))
if 'IBN
QUIT
Begin DoDot:1
+9 ; update display with status
+10 SET C=C+1
IF C#20
WRITE "."
+11 ; don't send if we already have a pending message for this insurance company
+12 if $DATA(^IBCNH(367.1,"INS",IBN))
QUIT
+13 ; don't send if we already have a NIF ID for this insurance company
+14 if $$NIF^IBCNHUT1(IBN)
QUIT
+15 ; don't send if there are no patients associated with this ins.co. OR if there are no groups associated with this insurance co.
+16 if '$DATA(^DPT("AB",IBN))
QUIT
+17 if '$DATA(^IBA(355.3,"B",IBN))
QUIT
+18 ; only active insurance companies
+19 if $PIECE($GET(^DIC(36,IBN,0)),U,5)=1
QUIT
+20 ; from here we can kick off the HL7 message.
+21 DO SEND^IBCNHHLO(IBN)
End DoDot:1
+22 KILL IBN,DIE,DA,DR,C
+23 QUIT
+24 ;
FM36(INS,DATA,TQN) ; updates file 36, 8 node with data received from the NIF
+1 ; INS = insurance company ien (REQUIRED)
+2 ; DATA=String containing HPID data in this format: HPID^CHP/SHP^PARENT^NIF ID
+3 ; NIF = NIF ID for insurance company
+4 ; TQN=ien of entry in file 367.1 (if data came from a requested response)
+5 ; returns "-1^Error code^Error reason" if entry not added and Processing Status if added/updated
+6 ;
+7 NEW DIC,DR,DA,DIE,I,X
+8 if INS=""
QUIT "-1^ED^DATABASE Error: Not a valid Insurance Company ien!"
+9 ; validate Vista Unique ID and HPID data format
+10 if '$DATA(^DIC(36,INS))
QUIT "-1^ED^Error: Insurance ien does NOT exist at this site!"
+11 ; don't update insurance file if Legacy ID's have changed since we sent the request
+12 if $$LEG($GET(TQN),INS)
QUIT "-1^EL^LEGACY ID Error: Legacy ID Changed!"
+13 ; ready to update file 36, fields 8.01, 8.02, 8.03 and 8.04 with DATA
+14 SET DIE="^DIC(36,"
SET DA=INS
SET DR=""
KILL DIC
+15 FOR I=2:1:4
SET DR=DR_"8.0"_I_"///^S X=$P(DATA,U,"_I_");"
+16 DO ^DIE
+17 ; add HPID separately since if it fails input transform nothing else updates
+18 SET DR="8.01///^S X=$P(DATA,U)"
DO ^DIE
+19 KILL DIE,DR,I,INS,X,LID,DIC
+20 QUIT DA_"^R^RESPONSE PROCESSED: File 36 Updated"
+21 ;
FM71(INS,HLID) ; adds entry to file 367.1 (HPID/OEID TRANSMISSION QUEUE) and file 367 (HPID/OEID RESPONSE)
+1 ; INS =insurance company ien (required)
+2 ; HLID = message control ID number assigned by HL7 when HL7 message was created (required)
+3 ; returns ien of entry added to file 367.1
+4 ;
+5 NEW DIC,DR,DA,DIE,Y,IDN,DATA,TQN,RSN,X,DLAYGO
+6 if INS=""
QUIT "-1^Error: Not a valid Insurance Company ien!"
+7 if HLID=""
QUIT "-1^Error: No HL7 Control Number defined!"
+8 SET DIC="^IBCNH(367.1,"
SET DIC(0)="LS"
SET X=$PIECE($GET(^IBCNH(367.1,0)),U,3)+1
SET DLAYGO=367.1
DO ^DIC
+9 if Y=-1
QUIT "-1^Error: HPID QUEUE entry NOT added!"
+10 SET TQN=+Y
+11 ; add stub record in file 367
+12 SET DIC="^IBCNH(367,"
SET DIC(0)="LS"
SET X=HLID
SET DLAYGO=367
DO ^DIC
+13 ; update 367 with additional fields.
+14 SET RSN=+Y
+15 IF Y>0
SET DIE=DIC
SET DA=+Y
SET DR=".01///"_HLID_";.02///"_TQN_";.03///R"
KILL DIC
DO ^DIE
+16 ; now update new 367.1 entry with insurance company data fields on 2 node, response info and status of A for AWAITING RESPONSE
+17 if '$$R36(INS,.DATA)
QUIT
+18 SET DIE="^IBCNH(367.1,"
SET DA=TQN
SET DR=""
KILL DIC
+19 SET DR=".02///"_INS_";"_".04///"_"A"_";.07///"_RSN
+20 FOR I=1:1:8
SET DR=DR_";2.0"_I_"///^S X=$P(DATA(1),U,"_I_")"
+21 DO ^DIE
+22 ; update ID multiple with ID data
+23 FOR IDN=1:1:10
IF $PIECE($GET(DATA(2)),U,IDN)'=""
Begin DoDot:1
+24 ; create ID multiple
+25 SET DIC="^IBCNH(367.1,"_TQN_",1,"
SET DA(1)=TQN
SET DIC(0)="LS"
SET X="`"_IDN
SET DLAYGO=367.1
DO ^DIC
if Y=-1
QUIT
+26 ; add ID data to new multiple entry
+27 SET DIE=DIC
SET DA=+Y
SET DR=".01///"_IDN_";.02///^S X=$P($G(DATA(2)),U,"_IDN_");.03///"_$PIECE($GET(DATA(3)),U,IDN)
KILL DIC
+28 DO ^DIE
End DoDot:1
+29 KILL DIC,DR,DA,DIE,Y,IDN,DATA,RSN,X,DLAYGO
+30 QUIT TQN
+31 ;
FM367(IEN,DATA,ID,QL) ; updates entry to file 367 (HPID/OEID RESPONSE) for requested responses,
+1 ; or creates a new entry for unsolicited responses.
+2 ; IEN = ien of existing entry in file 367 (will only exist for requested responses)
+3 ; DATA = data string containing response data for 0 node (NOTE: You do not have to pass all this data, but it must be in this format):
+4 ; HLID^TQN^RTY^INS NAME^NPS^STAT D/T^UID^PARENT HPID^CHP or SHP
+5 ; TQN = Transaction ien in file 367.1 (HPID/OEID TRANSMISSION QUEUE), null for unsolicited responses
+6 ; RTY = Response Type: R for Requested or U for Unsolicited
+7 ; NPS = Processing status at NIF, either R for Response Processed or X for Exception Report or EXR for Rejected
+8 ; HLID = control ID of HL7 message (required if this is an unsolicited response, not req'd if you have ien)
+9 ; ID = Data string of ID data sent from NIF. MUST BE in this format:
+10 ;(ie. HPID must always be 9th piece, NIF must be 8, If no EDI numbers received, those pieces will be null, etc.):
+11 ; EDI ID NUMBER-PROF^EDI ID NUMBER-INST^EDI PROF SECONDARY ID(1)^EDI PROF SECONDARY ID(2)^EDI INST SECONDARY ID(1)^EDI INST SECONDARY ID(2)^VA NATIONAL ID^NIF ID^HPID/OEID^VISTA UNIQUE ID
+12 ; QL=string of secondary ID qualifiers, in this format: ^^QUAL1(PS1)^QUAL2(PS2)^QAUL3(IS1)^QUAL4(IS2)
+13 ; RETURNS: IEN of file 367 entry that was updated, or -1 for error condition
+14 ;
+15 NEW DIC,DR,DA,DIE,Y,IDN,HLID,RTY,INS,TQN,PS,NPS,DLAYGO
+16 SET DATA=$GET(DATA)
SET ID=$GET(ID)
SET QL=$GET(QL)
+17 SET HLID=$PIECE($GET(DATA),U)
SET RTY=$PIECE($GET(DATA),U,3)
+18 IF RTY="R"
IF $GET(IEN)=""
QUIT "-1^Error: No HPID/OEID Response ien!"
+19 IF $GET(IEN)=""
IF $GET(HLID)=""
QUIT "-1^Error: No HPID/OEID Response and no HL7 ien!"
+20 ; if NIF processing status is not R, update response status only and quit
+21 if $PIECE(DATA,U,5)'="R"
QUIT $$STAT^IBCNHUT1(IEN,$PIECE(DATA,U,5))
+22 ; create new entry in 367 for unsolicited responses and update file 36 using NIF ID
+23 IF RTY="U"
SET IEN=$$UNSOL^IBCNHUT1(HLID,RTY,ID,DATA)
+24 if $PIECE(IEN,U)=-1
QUIT "-1^Error: HPID RESPONSE entry NOT added!"
+25 ; create and update ID multiple
+26 FOR IDN=1:1:10
IF $PIECE(ID,U,IDN)'=""
Begin DoDot:1
+27 SET DIC="^IBCNH(367,"_IEN_",1,"
SET DA(1)=IEN
SET DIC(0)="LS"
SET X="`"_IDN
SET DLAYGO=367
DO ^DIC
if Y=-1
QUIT
+28 SET DIE=DIC
SET DA=+Y
SET DR=".01///"_IDN_";.02///^S X=$P(ID,U,"_IDN_");.03///"_$PIECE(QL,U,IDN)
KILL DIC
+29 DO ^DIE
End DoDot:1
+30 ; update 367 with additional fields.
+31 SET DIE="^IBCNH(367,"
SET DA=IEN
SET DR=""
+32 FOR I=3,4,7,8,9
SET DR=DR_".0"_I_"///^S X=$P(DATA,U,"_I_");"
+33 DO ^DIE
+34 ; now update the insurance company entry in file 36 for requested responses. Use the insurance
+35 ; ien that was sent in the original request.
+36 ; Unsolicited response are updated via previous call to $$UNSOL^IBCNHUT1
+37 if RTY="U"
QUIT IEN
+38 SET INS=""
SET TQN=$PIECE($GET(^IBCNH(367,IEN,0)),U,2)
if TQN'=""
SET INS=$PIECE(^IBCNH(367.1,TQN,0),U,2)
+39 SET PS=$$FM36(INS,$PIECE(ID,U,9)_U_$PIECE(DATA,U,9)_U_$PIECE(DATA,U,8)_U_$PIECE(ID,U,8),TQN)
+40 ; update field .05 in file 367 (PROCESSING STATUS)
+41 QUIT $$STAT^IBCNHUT1(IEN,$PIECE(PS,U,2))
+42 ;
R36(INS,DATA) ; this function gathers all the insurance company data we need to send to the NIF
+1 ; INS= ien of insurance company entry (required)
+2 ; DATA=name of array to store data results in
+3 ; Returns: DATA(0) = Insurance Ien^Insurance Company Name^INACTIVE FLAG^UID^NIF ID^HPID/OEID^CHP/SHP^PARENT HPID
+4 ; DATA(1) = STREET ADDRESS 1^STR AD2^CITY^STATE^ZIP^BILLING CO NAME^TYPE OF COVERAGE^PHONE#
+5 ; DATA(2) = string of ID's in this format:
+6 ; EDI ID NUMBER-PROF^EDI ID NUMBER-INST^EDI PROF SECONDARY ID(1)^EDI PROF SECONDARY ID(2)^EDI INST SECONDARY ID(1)^EDI INST SECONDARY ID(2)^VA NATIONAL ID^NIF ID^HPID/OEID^VISTA UNIQUE ID
+7 ; DATA(3) = string of ID qualifiers in this format: ^^QUAL1(PS1)^QUAL2(PS2)^QAUL3(IS1)^QUAL4(IS2)
+8 ;
+9 NEW ID,QL,I,ND
+10 FOR I=0:1:3
SET DATA(I)=""
+11 SET ND(.11)=$GET(^DIC(36,INS,.11))
SET ND(0)=$GET(^DIC(36,INS,0))
+12 FOR I=1,2,4:1:7
SET DATA(1)=DATA(1)_$PIECE(ND(.11),U,I)_U
+13 SET DATA(1)=DATA(1)_$PIECE(ND(0),U,13)_U_$PIECE($GET(^DIC(36,INS,.13)),U)
+14 SET ID(7)=$$VID^IBCNHUT1(INS)
SET ND(6)=$GET(^DIC(36,INS,6))
SET ND(3)=$GET(^DIC(36,INS,3))
+15 SET ID(3)=$PIECE(ND(6),U,6)
SET ID(4)=$PIECE(ND(6),U,8)
SET ID(5)=$PIECE(ND(6),U,2)
SET ID(6)=$PIECE(ND(6),U,4)
+16 SET QL(3)=$PIECE(ND(6),U,5)
SET QL(4)=$PIECE(ND(6),U,7)
SET QL(5)=$PIECE(ND(6),U)
SET QL(6)=$PIECE(ND(6),U,3)
+17 SET ID(1)=$PIECE(ND(3),U,2)
SET ID(2)=$PIECE(ND(3),U,4)
SET ID(10)=$$UID^IBCNHUT1(INS)
+18 SET DATA(0)=INS_U_$PIECE(ND(0),U)_U_$PIECE(ND(0),U,5)_U_$$UID^IBCNHUT1(INS)_U_$$NIF^IBCNHUT1(INS)_U_$$HPD^IBCNHUT1(INS)_U_$$SHP^IBCNHUT1(INS)_U_$$PHP^IBCNHUT1(INS)
+19 SET ID(8)=$PIECE(DATA(0),U,5)
SET ID(9)=$PIECE(DATA(0),U,6)
+20 FOR I=1:1:10
SET DATA(2)=DATA(2)_$GET(ID(I))_U
+21 FOR I=1:1:6
SET DATA(3)=DATA(3)_$GET(QL(I))_U
+22 KILL ID,QL,I,ND
+23 QUIT 1
+24 ;
SETUPVER ; Set up verifying of IB NIF TCP logical link
+1 ; IB*2.0*549 added method
+2 ;
+3 NEW CURRTIME,MTIME
+4 NEW DIFROM,LLIEN,NIFTM,XMDUN,XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,XX,YY,ZTRTN,ZTDESC
+5 NEW ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
+6 ;
+7 ; Only check for stuck messages in production
IF '$$PROD^XUPROD(1)
GOTO SETUPVRX
+8 ;
+9 ; Get IB NIF TCP data
SET NIFTM=$$GET1^DIQ(350.9,"1,",51.29,"I")
+10 ; MM message time is not defined
IF NIFTM=""
GOTO SETUPVRX
+11 ; IB NIF TCP Logical Link
SET LLIEN=$ORDER(^HLCS(870,"B","IB NIF TCP",""))
+12 IF LLIEN=""
GOTO SETUPVRX
+13 ;
+14 ; current $H time
SET CURRTIME=$PIECE($HOROLOG,",",2)
+15 ; build a FileMan date/time
SET MTIME=DT_"."_NIFTM
+16 ; convert to $H format
SET MTIME=$$FMTH^XLFDT(MTIME)
+17 ; $H time of MM message
SET MTIME=$PIECE(MTIME,",",2)
+18 ;
+19 ; If the current time is after the MailMan message time, then schedule the message for tomorrow at that time.
+20 ; Otherwise, schedule it for later today.
+21 SET ZTDTH=$SELECT(CURRTIME>MTIME:$HOROLOG+1,1:+$HOROLOG)_","_MTIME
+22 ;
+23 ; Set up the other TaskManager variables
+24 ; The tag that we want TASKMAN to call
SET ZTRTN="VERFYLNK^IBCNHUT2"
+25 SET ZTDESC="Verify HL7 Logical link 'IB NIF TCP' is running"
+26 SET ZTIO=""
+27 SET ZTSAVE("LLIEN")=""
+28 SET ZTSAVE("NIFTM")=""
+29 ; Call TaskManager
DO ^%ZTLOAD
+30 ; Task # is not okay
IF '$GET(ZTSK)
Begin DoDot:1
+31 ;
+32 ; Send a MailMan message if this Task could not get scheduled
+33 SET MGRP="VHAeInsuranceRapidResponse@domain.ext"
+34 ;
+35 SET XMSUB=" Daily verification of IB NIF TCP link Not Scheduled"
+36 SET XMTEXT="XMTEXT("
+37 SET XMTEXT(1)="TaskManager could not schedule the daily verification of IB NIF TCP link"
+38 SET XMTEXT(2)="at the specified time of "_$EXTRACT(NIFTM,1,2)_":"_$EXTRACT(NIFTM,3,4)_"."
+39 DO ^XMD
End DoDot:1
+40 ;
SETUPVRX ;
+1 QUIT
+2 ;
VERFYLNK ; Verify IB NIF TCP entry in the HL Logical Link file (#870) on a daily basis
+1 ; IB*2.0*549 added Method
+2 ; Input - LLIEN [thru ZTSAVE("LLIEN")]
+3 ; NIFTM [thru ZTSAVE("NIFTM")]
+4 ;
+5 NEW FLG,IEN,X,XMSUB,XMTEXT,XMY,XX,YY
+6 SET IEN=$ORDER(^HLMA("AC","O",LLIEN,""))
+7 IF IEN=""
SET FLG=1
+8 IF '$TEST
Begin DoDot:1
+9 HANG 30
+10 ; Processing observed / No processing
SET FLG=$SELECT('$DATA(^HLMA("AC","O",LLIEN,IEN)):1,1:0)
End DoDot:1
+11 ;
+12 ; Link is apparently not processing records
IF 'FLG
Begin DoDot:1
+13 SET XX=$$SITE^VASITE()
+14 SET YY=$PIECE(XX,"^",2)_"(#"_$PIECE(XX,"^",1)_")"
+15 SET X="No activity seen in link"
+16 ;
+17 ; Send a MailMan message if link is not processing records
+18 SET XMY("VHAeInsuranceRapidResponse@domain.ext")=""
+19 SET XMY(.5)=""
+20 ;
+21 SET XMSUB=" Daily verification of IB NIF TCP link: "_X
+22 SET XMTEXT="XMTEXT("
+23 SET XMTEXT(1)="Daily verification of IB NIF TCP was unsuccessful ("_X_")"
+24 SET XMTEXT(2)="at the specified time of "_$EXTRACT(NIFTM,1,2)_":"_$EXTRACT(NIFTM,3,4)_" for site: "_YY_"."
+25 DO ^XMD
End DoDot:1
+26 QUIT
+27 ;
LEG(TQN,INS) ; function to determine if legacy ID's changed since we sent them out
+1 ; returns a 0 if Legacy ID has not changed and a "1^EL^Error: Legacy ID Changed!" if it has.
+2 ;
+3 NEW N,TID,I
+4 if TQN=""
QUIT 0
+5 if INS=""
QUIT 0
+6 FOR I=1,2
Begin DoDot:1
+7 SET N=$ORDER(^IBCNH(367.1,TQN,1,"B",I,""))
if N=""
QUIT
+8 SET TID(I)=$PIECE($GET(^IBCNH(367.1,TQN,1,N,0)),U,2)
End DoDot:1
+9 if $GET(TID(1))'=$PIECE($GET(^DIC(36,INS,3)),U,2)
QUIT "1^EL^Error: Legacy ID Changed!"
+10 if $GET(TID(2))'=$PIECE($GET(^DIC(36,INS,3)),U,4)
QUIT "1^EL^Error: Legacy ID Changed!"
+11 KILL N,TID,I
+12 QUIT 0
+13 ;
SMAIL(MGRP,XMSUB,MSG) ; Summary email
+1 ; IB*2.0*549 Send e-mail
+2 NEW DIFROM,XMDUN,XMDUZ,XMMG,XMTEXT,XMY,XMZ
+3 SET XMY(MGRP)=""
+4 SET XMTEXT=MSG
+5 DO ^XMD
+6 QUIT
