IVMLINS2 ;ALB/KCL - IVM INSURANCE POLICY PURGE ; 14 Feb 2014 1:53 PM
;;2.0;INCOME VERIFICATION MATCH;**14,34,111,156**; 21-OCT-94;Build 3
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
ASK ; - ask user to 'T'ransfer or 'P'urge IVM insurance policy
S DIR(0)="S^1:Transfer IVM Insurance Policy to insurance module;2:Purge IVM Insurance Policy;3:Return to Display Screen"
S DIR("A")="Select Action",DIR("?")="^D HLP1^IVMLINS2"
D ^DIR K DIR S IVMACT=Y G:$D(DIRUT)!($D(DUOUT))!(IVMACT=3) IVMQ^IVMLINS3
I IVMACT[1 D TRANSFER^IVMLINS3(0) Q
;
;
PURGE ; - purge IVM insurance information - ask for reason why
;
W !!,"The 'Purge IVM Insurance Policy' action has been selected."
;
W !!,"This action will cause the insurance information which has been"
W !,"received from HEC to be deleted from the system!",!,*7
;
W !,"Please select a reason for purging the IVM insurance information."
S DIC="^IVM(301.91,",DIC("A")="Select reason for purging: ",DIC(0)="QEAMZ"
D ^DIC K DIC G:Y<0!($D(DTOUT))!($D(DUOUT)) ASK
S IVMREPTR=+Y
;
; - ask user 'are you sure you want to purge'
W ! S DIR(0)="Y",DIR("A")="Are you sure that you want to purge IVM insurance policy"
;
; - set default = 'NO'
S DIR("B")="NO"
;
; - user help
S DIR("?")="Answer 'Y'ES to go ahead with this action or 'N'O to abort"
D ^DIR K DIR G:'Y ASK
;
; - update the INSURANCE SEGMENT multiple stored in (#301.5) file
W !!,"Purging the 'Insurance Policy' received from IVM... "
N DA,DR,DIE,IVMINSST
;
; stuff UPLOAD INSURANCE DATA(.04) and REASON NOT UPLOADING INSURANCE
; (.08)
S DA=IVMJ,DA(1)=IVMI
S DIE="^IVM(301.5,"_DA(1)_",""IN"","
S DR=".04////0;.08////^S X=IVMREPTR" D ^DIE
;
S IVMINSST=0
D HL7 ;send HL7 message to HEC
;
DELETE ; - delete segment name (.02 field of 301.501 multiple) from IVM PATIENT
; file to remove from ASEG cross-reference
;
S DA=IVMJ,DA(1)=IVMI
S DIE="^IVM(301.5,"_DA(1)_",""IN"",",DR=".02////@" D ^DIE
;
; - delete incoming segments strings
K ^IVM(301.5,DA(1),"IN",DA,"ST"),^("ST1")
W "completed.",!
;
S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
;
; - delete entry from the List Manager display once purged
K ^TMP("IVMIUPL",$J,IVMNAME,IVMI,IVMJ)
;
; - action completed
S IVMDONE=1
D IVMQ^IVMLINS3
Q
;
HL7 ; - send HL7 message to HEC
;
N IVMIN1,IVMIN2,IVMZIV
N HLEID,HL,HLRESLT
;
; MESSAGE PROTOCOL
S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORU-Z04 SERVER V"
S HLEID=$O(^ORD(101,"B",HLEID,0))
;
; - initialize variables for HL7/IVM
D INIT^IVMUFNC(HLEID,.HL) S HLMTN="ORU"
I $O(HL(""))="" QUIT ; the protocol is disabled or could not be initialized
;
;
; - create PID,IN1,ZIV segments
;
; - PID segment
K IVMPID,VAFPID
S IVMPID=$$EN^VAFHLPID(DFN,"1,3,5,7,19")
I $P(IVMPID,HLFS,20)["P" D PSEUDO^IVMPTRN1
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMPID
K IVMPID,VAFPID
;
; - IN1 segment
S IVMIN1="IN1^1"
S IVMIN2=$G(^IVM(301.5,IVMI,"IN",IVMJ,"ST"))_$G(^("ST1"))
S $P(IVMIN1,"^",5)=$P(IVMIN2,"^",4)
S $P(IVMIN1,"^",37)=$P(IVMIN2,"^",36)
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMIN1
;
; - ZIV segment
S IVMZIV="ZIV^1"
; - get ivm ien, strip off date of death
S $P(IVMZIV,"^",10)=$P($P($G(^IVM(301.5,IVMI,"IN",IVMJ,0)),"^",7),"/")
S $P(IVMZIV,"^",11)=IVMINSST
S:IVMINSST=0 $P(IVMZIV,"^",12)=IVMREPTR
S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMZIV
;
D GENERATE^HLMA(HLEID,"GM",1,.HLRESLT) ; - create mail message
K ^TMP("HLS",$J)
D CLEAN^IVMUFNC
Q
;
DOD ; - Alert user if date of death reported in DHCP or from HEC
;
W !!,*7,"'Date of Death' reported for this patient "
W $S($P($G(^DPT(+DFN,.35)),"^")]"":"in DHCP as "_$$DAT2^IVMUFNC4($P($G(^DPT(+DFN,.35)),"^")),$P(IVMDND,"^",6)]"":"by HEC as "_$$DAT2^IVMUFNC4($P(IVMDND,"^",6)))_".",!
S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
Q
;
;
HLP1 ; - help for ASK Transfer or Purge
;
; - if user enters single '?'
I X="?" D
.W !!,"Enter one of the following responses:"
.W !," 1 - to transfer the Insurance Policy that was received from HEC to the insurance module"
.W !," 2 - to delete the Insurance Policy that was received from HEC"
.W !," 3 - to return to the previous display screen"
.W !," '^' - to return to the previous display screen"
;
; - if user enters double '??'
I X="??" D
.W !!,"Entering '1' at this prompt will allow the user to transfer the Insurance Policy"
.W !,"that was received from HEC to the insurance module. Entering '2' at this prompt"
.W !,"will allow the user to delete the Insurance Policy that was received from HEC."
.W !,"Entering '3' or '^' will abort this action."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMLINS2 4762 printed Dec 13, 2024@02:02 Page 2
IVMLINS2 ;ALB/KCL - IVM INSURANCE POLICY PURGE ; 14 Feb 2014 1:53 PM
+1 ;;2.0;INCOME VERIFICATION MATCH;**14,34,111,156**; 21-OCT-94;Build 3
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
ASK ; - ask user to 'T'ransfer or 'P'urge IVM insurance policy
+1 SET DIR(0)="S^1:Transfer IVM Insurance Policy to insurance module;2:Purge IVM Insurance Policy;3:Return to Display Screen"
+2 SET DIR("A")="Select Action"
SET DIR("?")="^D HLP1^IVMLINS2"
+3 DO ^DIR
KILL DIR
SET IVMACT=Y
if $DATA(DIRUT)!($DATA(DUOUT))!(IVMACT=3)
GOTO IVMQ^IVMLINS3
+4 IF IVMACT[1
DO TRANSFER^IVMLINS3(0)
QUIT
+5 ;
+6 ;
PURGE ; - purge IVM insurance information - ask for reason why
+1 ;
+2 WRITE !!,"The 'Purge IVM Insurance Policy' action has been selected."
+3 ;
+4 WRITE !!,"This action will cause the insurance information which has been"
+5 WRITE !,"received from HEC to be deleted from the system!",!,*7
+6 ;
+7 WRITE !,"Please select a reason for purging the IVM insurance information."
+8 SET DIC="^IVM(301.91,"
SET DIC("A")="Select reason for purging: "
SET DIC(0)="QEAMZ"
+9 DO ^DIC
KILL DIC
if Y<0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO ASK
+10 SET IVMREPTR=+Y
+11 ;
+12 ; - ask user 'are you sure you want to purge'
+13 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure that you want to purge IVM insurance policy"
+14 ;
+15 ; - set default = 'NO'
+16 SET DIR("B")="NO"
+17 ;
+18 ; - user help
+19 SET DIR("?")="Answer 'Y'ES to go ahead with this action or 'N'O to abort"
+20 DO ^DIR
KILL DIR
if 'Y
GOTO ASK
+21 ;
+22 ; - update the INSURANCE SEGMENT multiple stored in (#301.5) file
+23 WRITE !!,"Purging the 'Insurance Policy' received from IVM... "
+24 NEW DA,DR,DIE,IVMINSST
+25 ;
+26 ; stuff UPLOAD INSURANCE DATA(.04) and REASON NOT UPLOADING INSURANCE
+27 ; (.08)
+28 SET DA=IVMJ
SET DA(1)=IVMI
+29 SET DIE="^IVM(301.5,"_DA(1)_",""IN"","
+30 SET DR=".04////0;.08////^S X=IVMREPTR"
DO ^DIE
+31 ;
+32 SET IVMINSST=0
+33 ;send HL7 message to HEC
DO HL7
+34 ;
DELETE ; - delete segment name (.02 field of 301.501 multiple) from IVM PATIENT
+1 ; file to remove from ASEG cross-reference
+2 ;
+3 SET DA=IVMJ
SET DA(1)=IVMI
+4 SET DIE="^IVM(301.5,"_DA(1)_",""IN"","
SET DR=".02////@"
DO ^DIE
+5 ;
+6 ; - delete incoming segments strings
+7 KILL ^IVM(301.5,DA(1),"IN",DA,"ST"),^("ST1")
+8 WRITE "completed.",!
+9 ;
+10 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
+11 ;
+12 ; - delete entry from the List Manager display once purged
+13 KILL ^TMP("IVMIUPL",$JOB,IVMNAME,IVMI,IVMJ)
+14 ;
+15 ; - action completed
+16 SET IVMDONE=1
+17 DO IVMQ^IVMLINS3
+18 QUIT
+19 ;
HL7 ; - send HL7 message to HEC
+1 ;
+2 NEW IVMIN1,IVMIN2,IVMZIV
+3 NEW HLEID,HL,HLRESLT
+4 ;
+5 ; MESSAGE PROTOCOL
+6 SET HLEID="VAMC "_$PIECE($$SITE^VASITE,"^",3)_" ORU-Z04 SERVER V"
+7 SET HLEID=$ORDER(^ORD(101,"B",HLEID,0))
+8 ;
+9 ; - initialize variables for HL7/IVM
+10 DO INIT^IVMUFNC(HLEID,.HL)
SET HLMTN="ORU"
+11 ; the protocol is disabled or could not be initialized
IF $ORDER(HL(""))=""
QUIT
+12 ;
+13 ;
+14 ; - create PID,IN1,ZIV segments
+15 ;
+16 ; - PID segment
+17 KILL IVMPID,VAFPID
+18 SET IVMPID=$$EN^VAFHLPID(DFN,"1,3,5,7,19")
+19 IF $PIECE(IVMPID,HLFS,20)["P"
DO PSEUDO^IVMPTRN1
+20 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=IVMPID
+21 KILL IVMPID,VAFPID
+22 ;
+23 ; - IN1 segment
+24 SET IVMIN1="IN1^1"
+25 SET IVMIN2=$GET(^IVM(301.5,IVMI,"IN",IVMJ,"ST"))_$GET(^("ST1"))
+26 SET $PIECE(IVMIN1,"^",5)=$PIECE(IVMIN2,"^",4)
+27 SET $PIECE(IVMIN1,"^",37)=$PIECE(IVMIN2,"^",36)
+28 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=IVMIN1
+29 ;
+30 ; - ZIV segment
+31 SET IVMZIV="ZIV^1"
+32 ; - get ivm ien, strip off date of death
+33 SET $PIECE(IVMZIV,"^",10)=$PIECE($PIECE($GET(^IVM(301.5,IVMI,"IN",IVMJ,0)),"^",7),"/")
+34 SET $PIECE(IVMZIV,"^",11)=IVMINSST
+35 if IVMINSST=0
SET $PIECE(IVMZIV,"^",12)=IVMREPTR
+36 SET IVMCT=IVMCT+1
SET ^TMP("HLS",$JOB,IVMCT)=IVMZIV
+37 ;
+38 ; - create mail message
DO GENERATE^HLMA(HLEID,"GM",1,.HLRESLT)
+39 KILL ^TMP("HLS",$JOB)
+40 DO CLEAN^IVMUFNC
+41 QUIT
+42 ;
DOD ; - Alert user if date of death reported in DHCP or from HEC
+1 ;
+2 WRITE !!,*7,"'Date of Death' reported for this patient "
+3 WRITE $SELECT($PIECE($GET(^DPT(+DFN,.35)),"^")]"":"in DHCP as "_$$DAT2^IVMUFNC4($PIECE($GET(^DPT(+DFN,.35)),"^")),$PIECE(IVMDND,"^",6)]"":"by HEC as "_$$DAT2^IVMUFNC4($PIECE(IVMDND,"^",6)))_".",!
+4 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
+5 QUIT
+6 ;
+7 ;
HLP1 ; - help for ASK Transfer or Purge
+1 ;
+2 ; - if user enters single '?'
+3 IF X="?"
Begin DoDot:1
+4 WRITE !!,"Enter one of the following responses:"
+5 WRITE !," 1 - to transfer the Insurance Policy that was received from HEC to the insurance module"
+6 WRITE !," 2 - to delete the Insurance Policy that was received from HEC"
+7 WRITE !," 3 - to return to the previous display screen"
+8 WRITE !," '^' - to return to the previous display screen"
End DoDot:1
+9 ;
+10 ; - if user enters double '??'
+11 IF X="??"
Begin DoDot:1
+12 WRITE !!,"Entering '1' at this prompt will allow the user to transfer the Insurance Policy"
+13 WRITE !,"that was received from HEC to the insurance module. Entering '2' at this prompt"
+14 WRITE !,"will allow the user to delete the Insurance Policy that was received from HEC."
+15 WRITE !,"Entering '3' or '^' will abort this action."
End DoDot:1
+16 QUIT
