IVMLINS4 ;ALB/SEK - IVM INSURANCE UPLOAD ACCEPT - IB CALL ; 30 JAN 2009
;;2.0;INCOME VERIFICATION MATCH;**14,135**; 21-OCT-94;Build 1
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; This routine is called by IB to update insurance segments sent
; from HEC and stored in the INCOMING SEGMENT multiple of the IVM
; PATIENT file (#301.5). A HL7 message is sent to HEC indicating if
; the data is accepted or rejected (including reason for rejection).
;
; Before this call, IB code allows the user to to review the
; insurance policy from HEC stored in IB's insurance module. When
; the user decides to accept or reject the policy, this routine is
; called. If the policy is rejected, this routine allows the user
; to pick the reason for rejection.
;
UPDATE(DFN,IVMINSST,IVMID,IVMREPTR,IVMSUPPR) ;
;
; Input: DFN -- internal entry number of PATIENT file
; IVMINSST -- upload status 1-accepted 0-rejected
; IVMID -- ins. co. name ^ street add[line 1] ^ group #
; IVMREPTR -- IVM REASONS FOR NOT UPLOADING (#301.91) IEN
; (Optional)
; IVMSUPPR -- Suppress Write and Interactive Lookup when > 0
; (Optional)
;
; Output: returns 1 if updated or 0 followed by error if not updated
;
N IVM1INSN,IVM2SA1,IVM3GNU,IVMI,IVMIBERR,IVMJ,IVMDA,IVMDAIN,IVMFOUND
I '$G(DFN)!('$D(^DPT(+DFN,0))) S IVMIBERR="No patient defined" G EXIT
I '$D(^IVM(301.5,"B",DFN)) S IVMIBERR="Patient not in IVM PATIENT file" G EXIT
;
I $G(IVMINSST)'=0&($G(IVMINSST)'=1) S IVMIBERR="upload status not accepted or rejected" G EXIT
;
; - check id fields
S IVM1INSN=$P(IVMID,"^")
S IVM2SA1=$P(IVMID,"^",2)
S IVM3GNU=$P(IVMID,"^",3)
I IVM1INSN']"" S IVMIBERR="no insurance company name from MCCR insurance module" G EXIT
I IVM2SA1']"" S IVMIBERR="no street address from MCCR insurance module" G EXIT
I IVM3GNU']"" S IVMIBERR="no group number from MCCR insurance module" G EXIT
;
S IVMDA=0
F S IVMDA=$O(^IVM(301.5,"B",DFN,IVMDA)) Q:'IVMDA D FIND Q:$G(IVMFOUND)
G PROCESS
;
; - find ins. record in IVM PATIENT file
FIND S IVMDAIN=0
F S IVMDAIN=$O(^IVM(301.5,IVMDA,"IN",IVMDAIN)) Q:'IVMDAIN D Q:$G(IVMFOUND)
.; - record missing
.Q:'$D(^IVM(301.5,IVMDA,"IN",IVMDAIN,0))
.Q:'$D(^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST"))
.;
.; - if 2nd piece not null - skip record - insurance record not transferred
.Q:$P($G(^IVM(301.5,IVMDA,"IN",IVMDAIN,0)),"^",2)]""
.;
.; - if 4th piece not null - skip record - already uploaded or rejected
.Q:$P($G(^IVM(301.5,IVMDA,"IN",IVMDAIN,0)),"^",4)]""
.;
.; - check 3 fields in ^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST") if not 3 matches - skip record
.Q:$P(^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST"),"^",4)'=IVM1INSN
.Q:$P($P(^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST"),"^",5),"~")'=IVM2SA1
.Q:$P(^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST"),"^",8)'=IVM3GNU
.; - if ins record found
.S IVMFOUND=1
.Q
Q
;
PROCESS I 'IVMDAIN S IVMIBERR="Insurance data not found in IVM PATIENT file" G EXIT
;
N DA,DTOUT,DUOUT,DR,DIE,Y
;
; - if the insurance data is accepted do
I IVMINSST D G DEL
.;
.; - stuff UPLOAD INSURANCE DATA(.04), UPLOADED INSURANCE DATE/TIME(.05)
.S DA=IVMDAIN,DA(1)=IVMDA
.S DIE="^IVM(301.5,"_DA(1)_",""IN"","
.S DR=".04////1;.05///NOW" D ^DIE
;
; - if the insurance data is rejected and writes/prompts not suppressed
; then ask for reason why
;
D:$G(IVMSUPPR)'>0
. W !!,"The 'Reject IVM Insurance Policy' action has been selected."
. W !,"Please select a reason for rejecting the IVM insurance information."
. S DIC="^IVM(301.91,",DIC("A")="Select reason for rejecting: ",DIC(0)="QEAMZ"
. D ^DIC K DIC I Y<0!($D(DTOUT))!($D(DUOUT)) S IVMREPTR=0 Q
. S IVMREPTR=+Y
;
;If IVMREPTR hasn't been defined, give error message and exit
I $G(IVMREPTR)'>0 S IVMIBERR="No reason selected" G EXIT
;
; stuff UPLOAD INSURANCE DATA(.04) and REASON NOT UPLOADING INSURANCE
; (.08)
S DA=IVMDAIN,DA(1)=IVMDA
S DIE="^IVM(301.5,"_DA(1)_",""IN"","
S DR=".04////0;.08////^S X=IVMREPTR" D ^DIE
;
DEL ; - delete incoming segments strings
K ^IVM(301.5,DA(1),"IN",DA,"ST"),^("ST1")
;
; - send HL7 message to IVM Center
;
S IVMI=DA(1),IVMJ=DA
D HL7^IVMLINS2
;
EXIT Q $S($D(IVMIBERR):0,1:1)_"^"_$G(IVMIBERR)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMLINS4 4371 printed Nov 22, 2024@17:12:10 Page 2
IVMLINS4 ;ALB/SEK - IVM INSURANCE UPLOAD ACCEPT - IB CALL ; 30 JAN 2009
+1 ;;2.0;INCOME VERIFICATION MATCH;**14,135**; 21-OCT-94;Build 1
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This routine is called by IB to update insurance segments sent
+5 ; from HEC and stored in the INCOMING SEGMENT multiple of the IVM
+6 ; PATIENT file (#301.5). A HL7 message is sent to HEC indicating if
+7 ; the data is accepted or rejected (including reason for rejection).
+8 ;
+9 ; Before this call, IB code allows the user to to review the
+10 ; insurance policy from HEC stored in IB's insurance module. When
+11 ; the user decides to accept or reject the policy, this routine is
+12 ; called. If the policy is rejected, this routine allows the user
+13 ; to pick the reason for rejection.
+14 ;
UPDATE(DFN,IVMINSST,IVMID,IVMREPTR,IVMSUPPR) ;
+1 ;
+2 ; Input: DFN -- internal entry number of PATIENT file
+3 ; IVMINSST -- upload status 1-accepted 0-rejected
+4 ; IVMID -- ins. co. name ^ street add[line 1] ^ group #
+5 ; IVMREPTR -- IVM REASONS FOR NOT UPLOADING (#301.91) IEN
+6 ; (Optional)
+7 ; IVMSUPPR -- Suppress Write and Interactive Lookup when > 0
+8 ; (Optional)
+9 ;
+10 ; Output: returns 1 if updated or 0 followed by error if not updated
+11 ;
+12 NEW IVM1INSN,IVM2SA1,IVM3GNU,IVMI,IVMIBERR,IVMJ,IVMDA,IVMDAIN,IVMFOUND
+13 IF '$GET(DFN)!('$DATA(^DPT(+DFN,0)))
SET IVMIBERR="No patient defined"
GOTO EXIT
+14 IF '$DATA(^IVM(301.5,"B",DFN))
SET IVMIBERR="Patient not in IVM PATIENT file"
GOTO EXIT
+15 ;
+16 IF $GET(IVMINSST)'=0&($GET(IVMINSST)'=1)
SET IVMIBERR="upload status not accepted or rejected"
GOTO EXIT
+17 ;
+18 ; - check id fields
+19 SET IVM1INSN=$PIECE(IVMID,"^")
+20 SET IVM2SA1=$PIECE(IVMID,"^",2)
+21 SET IVM3GNU=$PIECE(IVMID,"^",3)
+22 IF IVM1INSN']""
SET IVMIBERR="no insurance company name from MCCR insurance module"
GOTO EXIT
+23 IF IVM2SA1']""
SET IVMIBERR="no street address from MCCR insurance module"
GOTO EXIT
+24 IF IVM3GNU']""
SET IVMIBERR="no group number from MCCR insurance module"
GOTO EXIT
+25 ;
+26 SET IVMDA=0
+27 FOR
SET IVMDA=$ORDER(^IVM(301.5,"B",DFN,IVMDA))
if 'IVMDA
QUIT
DO FIND
if $GET(IVMFOUND)
QUIT
+28 GOTO PROCESS
+29 ;
+30 ; - find ins. record in IVM PATIENT file
FIND SET IVMDAIN=0
+1 FOR
SET IVMDAIN=$ORDER(^IVM(301.5,IVMDA,"IN",IVMDAIN))
if 'IVMDAIN
QUIT
Begin DoDot:1
+2 ; - record missing
+3 if '$DATA(^IVM(301.5,IVMDA,"IN",IVMDAIN,0))
QUIT
+4 if '$DATA(^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST"))
QUIT
+5 ;
+6 ; - if 2nd piece not null - skip record - insurance record not transferred
+7 if $PIECE($GET(^IVM(301.5,IVMDA,"IN",IVMDAIN,0)),"^",2)]""
QUIT
+8 ;
+9 ; - if 4th piece not null - skip record - already uploaded or rejected
+10 if $PIECE($GET(^IVM(301.5,IVMDA,"IN",IVMDAIN,0)),"^",4)]""
QUIT
+11 ;
+12 ; - check 3 fields in ^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST") if not 3 matches - skip record
+13 if $PIECE(^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST"),"^",4)'=IVM1INSN
QUIT
+14 if $PIECE($PIECE(^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST"),"^",5),"~")'=IVM2SA1
QUIT
+15 if $PIECE(^IVM(301.5,IVMDA,"IN",IVMDAIN,"ST"),"^",8)'=IVM3GNU
QUIT
+16 ; - if ins record found
+17 SET IVMFOUND=1
+18 QUIT
End DoDot:1
if $GET(IVMFOUND)
QUIT
+19 QUIT
+20 ;
PROCESS IF 'IVMDAIN
SET IVMIBERR="Insurance data not found in IVM PATIENT file"
GOTO EXIT
+1 ;
+2 NEW DA,DTOUT,DUOUT,DR,DIE,Y
+3 ;
+4 ; - if the insurance data is accepted do
+5 IF IVMINSST
Begin DoDot:1
+6 ;
+7 ; - stuff UPLOAD INSURANCE DATA(.04), UPLOADED INSURANCE DATE/TIME(.05)
+8 SET DA=IVMDAIN
SET DA(1)=IVMDA
+9 SET DIE="^IVM(301.5,"_DA(1)_",""IN"","
+10 SET DR=".04////1;.05///NOW"
DO ^DIE
End DoDot:1
GOTO DEL
+11 ;
+12 ; - if the insurance data is rejected and writes/prompts not suppressed
+13 ; then ask for reason why
+14 ;
+15 if $GET(IVMSUPPR)'>0
Begin DoDot:1
+16 WRITE !!,"The 'Reject IVM Insurance Policy' action has been selected."
+17 WRITE !,"Please select a reason for rejecting the IVM insurance information."
+18 SET DIC="^IVM(301.91,"
SET DIC("A")="Select reason for rejecting: "
SET DIC(0)="QEAMZ"
+19 DO ^DIC
KILL DIC
IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
SET IVMREPTR=0
QUIT
+20 SET IVMREPTR=+Y
End DoDot:1
+21 ;
+22 ;If IVMREPTR hasn't been defined, give error message and exit
+23 IF $GET(IVMREPTR)'>0
SET IVMIBERR="No reason selected"
GOTO EXIT
+24 ;
+25 ; stuff UPLOAD INSURANCE DATA(.04) and REASON NOT UPLOADING INSURANCE
+26 ; (.08)
+27 SET DA=IVMDAIN
SET DA(1)=IVMDA
+28 SET DIE="^IVM(301.5,"_DA(1)_",""IN"","
+29 SET DR=".04////0;.08////^S X=IVMREPTR"
DO ^DIE
+30 ;
DEL ; - delete incoming segments strings
+1 KILL ^IVM(301.5,DA(1),"IN",DA,"ST"),^("ST1")
+2 ;
+3 ; - send HL7 message to IVM Center
+4 ;
+5 SET IVMI=DA(1)
SET IVMJ=DA
+6 DO HL7^IVMLINS2
+7 ;
EXIT QUIT $SELECT($DATA(IVMIBERR):0,1:1)_"^"_$GET(IVMIBERR)
