source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMLINS2.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1IVMLINS2 ;ALB/KCL - IVM INSURANCE POLICY PURGE ; 3/23/01 4:36pm
2 ;;2.0;INCOME VERIFICATION MATCH;**14,34,111**; 21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6ASK ; - ask user to 'T'ransfer or 'P'urge IVM insurance policy
7 S DIR(0)="S^1:Transfer IVM Insurance Policy to insurance module;2:Purge IVM Insurance Policy;3:Return to Display Screen"
8 S DIR("A")="Select Action",DIR("?")="^D HLP1^IVMLINS2"
9 D ^DIR K DIR S IVMACT=Y G:$D(DIRUT)!($D(DUOUT))!(IVMACT=3) IVMQ^IVMLINS3
10 I IVMACT[1 D TRANSFER^IVMLINS3(0) Q
11 ;
12 ;
13PURGE ; - purge IVM insurance information - ask for reason why
14 ;
15 W !!,"The 'Purge IVM Insurance Policy' action has been selected."
16 ;
17 W !!,"This action will cause the insurance information which has been"
18 W !,"received from HEC to be deleted from the system!",!,*7
19 ;
20 W !,"Please select a reason for purging the IVM insurance information."
21 S DIC="^IVM(301.91,",DIC("A")="Select reason for purging: ",DIC(0)="QEAMZ"
22 D ^DIC K DIC G:Y<0!($D(DTOUT))!($D(DUOUT)) ASK
23 S IVMREPTR=+Y
24 ;
25 ; - ask user 'are you sure you want to purge'
26 W ! S DIR(0)="Y",DIR("A")="Are you sure that you want to purge IVM insurance policy"
27 ;
28 ; - set default = 'NO'
29 S DIR("B")="NO"
30 ;
31 ; - user help
32 S DIR("?")="Answer 'Y'ES to go ahead with this action or 'N'O to abort"
33 D ^DIR K DIR G:'Y ASK
34 ;
35 ; - update the INSURANCE SEGMENT multiple stored in (#301.5) file
36 W !!,"Purging the 'Insurance Policy' received from IVM... "
37 N DA,DR,DIE,IVMINSST
38 ;
39 ; stuff UPLOAD INSURANCE DATA(.04) and REASON NOT UPLOADING INSURANCE
40 ; (.08)
41 S DA=IVMJ,DA(1)=IVMI
42 S DIE="^IVM(301.5,"_DA(1)_",""IN"","
43 S DR=".04////0;.08////^S X=IVMREPTR" D ^DIE
44 ;
45 S IVMINSST=0
46 D HL7 ;send HL7 message to HEC
47 ;
48DELETE ; - delete segment name (.02 field of 301.501 multiple) from IVM PATIENT
49 ; file to remove from ASEG cross-reference
50 ;
51 S DA=IVMJ,DA(1)=IVMI
52 S DIE="^IVM(301.5,"_DA(1)_",""IN"",",DR=".02////@" D ^DIE
53 ;
54 ; - delete incoming segments strings
55 K ^IVM(301.5,DA(1),"IN",DA,"ST"),^("ST1")
56 W "completed.",!
57 ;
58 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
59 ;
60 ; - delete entry from the List Manager display once purged
61 K ^TMP("IVMIUPL",$J,IVMNAME,IVMI,IVMJ)
62 ;
63 ; - action completed
64 S IVMDONE=1
65 D IVMQ^IVMLINS3
66 Q
67 ;
68HL7 ; - send HL7 message to HEC
69 ;
70 N IVMIN1,IVMIN2,IVMZIV
71 N HLEID,HL,HLRESLT
72 ;
73 ; MESSAGE PROTOCOL
74 S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORU-Z04 SERVER V"
75 S HLEID=$O(^ORD(101,"B",HLEID,0))
76 ;
77 ; - initialize variables for HL7/IVM
78 D INIT^IVMUFNC(HLEID,.HL) S HLMTN="ORU"
79 ;
80 ;
81 ; - create PID,IN1,ZIV segments
82 ;
83 ; - PID segment
84 K IVMPID,VAFPID
85 S IVMPID=$$EN^VAFHLPID(DFN,"1,3,5,7,19")
86 I $P(IVMPID,HLFS,20)["P" D PSEUDO^IVMPTRN1
87 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMPID
88 K IVMPID,VAFPID
89 ;
90 ; - IN1 segment
91 S IVMIN1="IN1^1"
92 S IVMIN2=$G(^IVM(301.5,IVMI,"IN",IVMJ,"ST"))_$G(^("ST1"))
93 S $P(IVMIN1,"^",5)=$P(IVMIN2,"^",4)
94 S $P(IVMIN1,"^",37)=$P(IVMIN2,"^",36)
95 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMIN1
96 ;
97 ; - ZIV segment
98 S IVMZIV="ZIV^1"
99 ; - get ivm ien, strip off date of death
100 S $P(IVMZIV,"^",10)=$P($P($G(^IVM(301.5,IVMI,"IN",IVMJ,0)),"^",7),"/")
101 S $P(IVMZIV,"^",11)=IVMINSST
102 S:IVMINSST=0 $P(IVMZIV,"^",12)=IVMREPTR
103 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMZIV
104 ;
105 D GENERATE^HLMA(HLEID,"GM",1,.HLRESLT) ; - create mail message
106 K ^TMP("HLS",$J)
107 D CLEAN^IVMUFNC
108 Q
109 ;
110DOD ; - Alert user if date of death reported in DHCP or from HEC
111 ;
112 W !!,*7,"'Date of Death' reported for this patient "
113 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)))_".",!
114 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
115 Q
116 ;
117 ;
118HLP1 ; - help for ASK Transfer or Purge
119 ;
120 ; - if user enters single '?'
121 I X="?" D
122 .W !!,"Enter one of the following responses:"
123 .W !," 1 - to transfer the Insurance Policy that was received from HEC to the insurance module"
124 .W !," 2 - to delete the Insurance Policy that was received from HEC"
125 .W !," 3 - to return to the previous display screen"
126 .W !," '^' - to return to the previous display screen"
127 ;
128 ; - if user enters double '??'
129 I X="??" D
130 .W !!,"Entering '1' at this prompt will allow the user to transfer the Insurance Policy"
131 .W !,"that was received from HEC to the insurance module. Entering '2' at this prompt"
132 .W !,"will allow the user to delete the Insurance Policy that was received from HEC."
133 .W !,"Entering '3' or '^' will abort this action."
134 Q
Note: See TracBrowser for help on using the repository browser.