source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGHTENR.m@ 1528

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1DGHTENR ;ALB/JAM - Home Telehealth Patient Sign-up;10 January 2005 ; 9/20/07 8:27am
2 ;;5.3;Registration;**644**;Aug 13, 1993;Build 11
3 ;
4EN N DGDFN,STOP,ARR,RESULT,DGVEN,DGPRV,DGCON,GETOK,DGHTH,DGMID,DGCHK,DGDEF
5 N DGEVNDT,VENDOR,DGTYPE
6 S ARR=$NA(HLA("HLS"))
7 S STOP=0
8 F D Q:STOP
9 .K DGHTH
10 .S DGHTH("DGTYPE")="A"
11 .;Get patient
12 .W !!
13 .S DGDFN=$$GETPAT() I 'DGDFN S STOP=1 Q
14 .S DGHTH("DFN")=DGDFN
15 .;Get receiving vendor
16 .S DGVEN=$$GETVEN() I 'DGVEN Q
17 .S DGHTH("VENDOR")=DGVEN
18 .;Check if Patient is already signed up
19 .S DGCHK=$$SGNUPCHK(.DGHTH)
20 .I 'DGCHK W " ...Patient Sign-Up/Activation request terminated." Q
21 .;Get consult number
22 .S DGDEF=$G(DGHTH("CONSULT")),DGCON=$$GCONSULT(DGDFN,DGDEF) I 'DGCON Q
23 .S DGHTH("CONSULT")=DGCON
24 .;Get Care Coordinator
25 .S DGDEF=$G(DGHTH("COORD")),DGPRV=$$GETPROV(DGDEF) I 'DGPRV Q
26 .S DGHTH("COORD")=DGPRV
27 .;Get okay for transmission
28 .S GETOK=$$SNDMSG(DGHTH("DGTYPE"))
29 .I 'GETOK W " ...Patient record not transmitted." Q
30 .;file patient data in #391.31
31 .S DGEVNDT=$$NOW^XLFDT(),DGHTH("EVENTDT")=DGEVNDT
32 .D FILE
33 .;build message
34 .W !!,"Generating HL7 message ..."
35 .K @ARR
36 .S RESULT=$$BLDHL7^DGHTHL7(.DGHTH,ARR)
37 .I +RESULT<0 D Q
38 ..W !,"** UNABLE TO BUILD MESSAGE **",!,$P(RESULT,"^",2) K @ARR
39 .I RESULT=0 D Q
40 ..W !,"** EMPTY MESSAGE BUILT **" K @ARR
41 .;send message
42 .W !,"Sending message ..."
43 .S RESULT=$$SNDHL7^DGHTHL7(ARR,DGVEN,"DG HOME TELEHEALTH ADT-A04 SERVER")
44 .I $P(RESULT,"^",2)'="" D Q
45 ..W !,"** UNABLE TO SEND MESSAGE **"
46 ..W !,"Error Code: ",$P(RESULT,"^",2)," Message: ",$P(RESULT,"^",3)
47 ..K @ARR
48 .;Update File #391.31 with message ID
49 .S DGMID=$P(RESULT,"^")
50 .D MIDUPD
51 .W !,"Sent using message ID ",$P(RESULT,"^")
52 .K @ARR
53 Q
54 ;
55SGNUPCHK(DGARY) ;Check if patient already signed up & whether to
56 ;continue signup for transmission
57 ;Input : Array with patient data with at least patient & vendor IEN
58 ;Output: 0 = Patient was signed up, terminate processing
59 ; 1 = Continue processing
60 ;
61 N X,Y,DA,DA1,DAIEN,DGDAT,DTOUT,DUOUT,DIR
62 S X="" F S X=$O(DGARY(X)) Q:X="" D
63 .I DGARY(X)="" K DGARY(X) Q
64 .S @X=DGARY(X)
65 I '$G(DFN)!('$G(VENDOR))!($G(DGTYPE)="") Q 1
66 S DAIEN=$$LOCREC^DGHTINAC(DFN,VENDOR,DGTYPE)
67 I 'DAIEN Q 1
68 W @IOF,!,"PATIENT ALREADY SIGNED-UP/ACTIVATED WITH VENDOR",!!
69 D DSPREC(DAIEN)
70 S DIR(0)="Y",DIR("A")="Continue Patient Sign-Up/Activation",DIR("B")="No"
71 S DIR("?")="Enter NO to terminate sign-up/activation or YES to continue sign-up/activation."
72 D ^DIR I Y D
73 .S DGDAT=^DGHT(391.31,$P(DAIEN,"^"),0),DGARY("DA")=DAIEN
74 .S DGARY("CONSULT")=$P(DGDAT,"^",4),DGARY("COORD")=$P(DGDAT,"^",5)
75 W !
76 Q $S(+Y<0:0,1:+Y)
77 ;
78DSPREC(DGIEN) ;Display Home Telehealth record
79 ;Input : IEN and sub IEN for Home Telehealth files #391.31 & #391.317
80 ;Output: Displays record if found
81 ;
82 N DA,DA1,DGDAT,DGDAT1
83 I $G(DGIEN)="" Q
84 S DA=$P(DGIEN,"^"),DA1=$P(DGIEN,"^",2)
85 I '+DA Q
86 S DGDAT=^DGHT(391.31,DA,0)
87 S DGDAT1=$S(DA1:^DGHT(391.31,DA,"TRAN",DA1,0),1:"")
88 W !?3,"Patient: ",$$GET1^DIQ(2,$P(DGDAT,"^",2),.01,"E")
89 W !?3,"Vendor: ",$$GET1^DIQ(4,$P(DGDAT,"^",3),.01,"E")
90 W !?3,"Care Coordinator: ",$$GET1^DIQ(200,$P(DGDAT,"^",5),.01,"E")
91 W ?45,"Consult Number: ",$P(DGDAT,"^",4)
92 W !?3,"Activation Date: ",$$FMTE^XLFDT($P(DGDAT,"^",6),2)
93 W:$P(DGDAT,"^",7)'="" ?45,"Inactivation Date: ",$$FMTE^XLFDT($P(DGDAT,"^",7),2)
94 I DGDAT1'="" D
95 .W !?3,"Transaction Date: ",$$FMTE^XLFDT($P(DGDAT1,"^"),2)
96 .W ?45,"Transaction Type: "
97 .W $S('$P(DGDAT1,"^",5):"Retransmit",$P(DGDAT1,"^",5)=1:"Add",1:"Edit")
98 .W !?3,"Message Type: ",$S($P(DGDAT1,"^",4)="A":"Activation",$P(DGDAT1,"^",4)="I":"Inactivation",1:"Unknown")
99 .W ?45,"Message ID: ",$P(DGDAT1,"^",2)
100 .W !?3,"Data Entry User: ",$$GET1^DIQ(200,$P(DGDAT1,"^",3),.01,"E")
101 .W !?3,"Acknowledge Date: ",$$FMTE^XLFDT($P(DGDAT1,"^",6),2)
102 .W ?45,"Acknowledge Code: "
103 .W $S($P(DGDAT1,"^",7)="A":"Accepted",$P(DGDAT1,"^",7)="R":"Rejected",1:"")
104 .I $P(DGDAT1,"^",8)'="" W !?3,"Reject Message: ",$P(DGDAT1,"^",8)
105 .W !
106 Q
107 ;
108GETPAT() ;Prompt user for patient
109 ;Input : None
110 ;Output: Pointer to PATIENT File, #2 (i.e. DFN)
111 ; 0 on user quit
112 N DIC,X,Y,DTOUT,DUOUT,IENVAL
113 S DIC="^DPT(",DIC("A")="Patient: ",DIC(0)="AEQM"
114 D ^DIC I +Y<0 Q 0
115 S IENVAL=$$PATOK(+Y) I 'IENVAL Q 0
116 Q +Y
117 ;
118PATOK(DFN) ;Patient screen
119 ;Input : DFN - Pointer to PATIENT
120 ;Output: 1 = Patient selectable
121 ; 0 = Patient not selectable
122 N NODE
123 ;Dead
124 I $G(^DPT(DFN,.35)) W !,"*** Patient has expired. ***" Q 0
125 ;No national ICN
126 S NODE=$G(^DPT(DFN,"MPI"))
127 I $P(NODE,"^",1)="" W !,"*** Patient has no ICN. ***" Q 0
128 ;Local ICN
129 I $P(NODE,"^",4) W !,"*** Patient has local ICN. ***" Q 0
130 ;Selectable patient
131 Q 1
132 ;
133GETVEN() ;Prompt user for receiving vendor
134 ;Input : None
135 ;Output: N = Pointer to INSTITUTION File, #4
136 ; 0 = User quit
137 ;
138 N DIR,X,Y,DTOUT,DUOUT,DIRUT
139 S DIR(0)="391.31,2",DIR("A")="Vendor"
140 S DIR("?")="Enter the Home Telehealth vendor patient is signed up with."
141 D ^DIR
142 Q $S(+Y<0:0,1:+Y)
143 ;
144GCONSULT(DFN,DEFAULT) ;Prompt Consult number from file #123
145 ;Input : DFN Patient pointer for file #2
146 ; DEFAULT Default value for consult number (if existing)
147 ;Output: N Pointer to REQUEST/CONSULTATION file, #123
148 ; 0 User quit
149 ;
150 N DIR,X,Y,DTOUT,DUOUT,DIRUT,CON,CONZER,DGTMP
151 ;find ien for 'CARE COORDINATION HOME TELEHEALTH SCREENING'
152 S CON="CARE COORDINATION HOME TELEHEALTH SCREENING"
153 K ^TMP("GMRCR",$J)
154 D GUI^GMRCASV1("DGTMP",CON,1,0) ;DBIA#3252
155 S CON=$O(DGTMP(0))
156 I 'CON W !,"Service Area not available" Q 0
157 S CON=+DGTMP(CON) ;DBIA#2740
158 D OER^GMRCSLM1(DFN,CON,"")
159 S CONZER=$G(^TMP("GMRCR",$J,"CS",0)),DIR("?")="^D CONHELP^DGHTENR"
160 I '+$P(CONZER,"^",4) D Q 0
161 .W !!,"No Home Telehealth consult available for this patient!!"
162 S DIR(0)="P^TMP(""GMRCR"",$J,""CS"",:AEQMZ",DIR("A")="Consult Number"
163 I $G(DEFAULT)'="" S DIR("B")=DEFAULT
164 D ^DIR
165 K ^TMP("GMRCR",$J)
166 Q $S(+Y<0:0,1:$P(Y,"^",2))
167 ;
168CONHELP ;Help for consult #
169 N DIC,XX,D
170 I $D(^TMP("GMRCR",$J,"CS")) D Q
171 .W !?1,"Answer with the number representing consult.",!?1,"Choose from:"
172 .S XX=0 F S XX=$O(^TMP("GMRCR",$J,"CS",XX)) Q:'XX D
173 ..W !?1,XX,")",?5,$P(^TMP("GMRCR",$J,"CS",XX,0),"^"),?15
174 ..W $$FMTE^XLFDT($P(^TMP("GMRCR",$J,"CS",XX,0),"^",2),"2HM"),?30
175 ..W $E($P(^TMP("GMRCR",$J,"CS",XX,0),"^",7),1,38),?70,$P(^TMP("GMRCR",$J,"CS",XX,0),"^",3)
176 S DIC="^TMP(""GMRCR"",$J,""CS"")",DIC(0)="MQEZ" D DQ^DICQ
177 Q
178 ;
179GETPROV(DEFAULT) ;Prompt for Care Coordinator
180 ;Input : DEFAULT = Default value for provider (if existing)
181 ;Output: N = Pointer to NEW PERSON file, #200
182 ; 0 = User quit
183 ;
184 N DIR,X,Y,DTOUT,DUOUT,DIRUT
185 S DIR(0)="P^VA(200,:AEQM",DIR("A")="Care Coordinator"
186 S DIR("?")="Enter the Care Coordinator responsible for signing up this patient."
187 I $G(DEFAULT)'="" S DIR("B")=$$GET1^DIQ(200,DEFAULT,.01,"E")
188 D ^DIR
189 Q $S(+Y<0:0,1:+Y)
190 ;
191SNDMSG(TYPE) ;Prompt to transmit transaction to vendor server
192 ;Input : None
193 ;Output: 1 = Send message
194 ; 0 = User quit
195 ;
196 N DIR,X,Y,DTOUT,DUOUT,DIRUT
197 S DIR(0)="Y",DIR("B")="Yes"
198 S DIR("A")=$S(TYPE="A":"Send Sign-Up/Activation",TYPE="I":"Send Inactivation",1:"")
199 S DIR("?")="Enter 'Yes' to transmit patient information to vendor. 'No' not to transmit."
200 D ^DIR
201 Q $S(+Y<0:0,1:+Y)
202 ;
203FILE ;File patient data in #391.31
204 N DIC,DIE,DA,DR,X,Y,DGRN,DGTREVN,DINUM
205 S DGTREVN=0
206 I $G(DGHTH("DA"))'="" D Q
207 .D FILE1
208HTADD L +^DGHT(391.31,0)
209 S DGRN=$P(^DGHT(391.31,0),"^",3)+1 I $D(^DGHT(391.31,DGRN)) D G HTADD
210 .S $P(^DGHT(391.31,0),"^",3)=$P(^(0),"^",3)+1 L -^DGHT(391.31,0)
211 L -^DGHT(391.31,0)
212 S DIC(0)="L",DIC="^DGHT(391.31,",X=DGRN,DINUM=X D FILE^DICN
213 S DGHTH("DA")=+Y,DGTREVN=1
214 ;
215FILE1 ;Add/Update fields in #391.31
216 S DIE="^DGHT(391.31,",DA=+DGHTH("DA")
217 S DR="1////"_DGDFN_";2////"_DGVEN_";3////"_DGCON_";4////"_DGPRV
218 S:DGTREVN DR=DR_";5////"_DGEVNDT
219 D ^DIE
220 ;file entry in subfile #391.317
221 K DIC,DD,DO,DA
222 S DIC(0)="L",DIC("P")=$P(^DD(391.31,7,0),"^",2),DA(1)=+DGHTH("DA")
223 I $P(DGHTH("DA"),"^",2)="" D
224 .S DGRN=$S('$D(^DGHTH(391.31,DA(1),"TRAN")):0,1:$P(^DGHTH(391.31,DA(1),"TRAN",0),"^",3))+1,$P(DGHTH("DA"),"^",2)=DGRN,X=DGEVNDT
225 .S DIC="^DGHT(391.31,"_DA(1)_","_"""TRAN"""_","
226 .D FILE^DICN
227 K DR
228 S DA=$P(DGHTH("DA"),"^",2),DIE="^DGHT(391.31,"_DA(1)_","_"""TRAN"""_","
229 S (DR,DR(2,391.317))=".01////"_DGEVNDT_";.02////@"_";.03////"_DUZ_";.04////"_DGTYPE_";.05////"_DGTREVN ;";.07////@" retain AA and trans. date/time when 1st transmitted successfully.
230 D ^DIE
231 Q
232 ;
233MIDUPD ;Update File #391.31 with message ID
234 N DIE,DR,DA,X,Y
235 S DA=$P(DGHTH("DA"),"^",2),DA(1)=+DGHTH("DA")
236 S (DR,DR(2,391.317))=".02////"_DGMID
237 S DIE="^DGHT(391.31,"_DA(1)_","_"""TRAN"""_","
238 D ^DIE
239 Q
Note: See TracBrowser for help on using the repository browser.