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

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

revised back to 6/30/08 version

File size: 5.0 KB
Line 
1DG10 ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 1/5/2006 21:46
2 ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,634**;Aug 13, 1993;Build 28
3 ; Modified from FOIA VISTA,
4 ; Copyright (C) 2007 WorldVistA
5 ;
6 ; This program is free software; you can redistribute it and/or modify
7 ; it under the terms of the GNU General Public License as published by
8 ; the Free Software Foundation; either version 2 of the License, or
9 ; (at your option) any later version.
10 ;
11 ; This program is distributed in the hope that it will be useful,
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ; GNU General Public License for more details.
15 ;
16 ; You should have received a copy of the GNU General Public License
17 ; along with this program; if not, write to the Free Software
18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
19START ;
20 D LO^DGUTL
21 I $G(DGPRFLG)=1,$G(DGPLOC)=1 D G Q:$G(DGRPOUT),A1
22 .; D EN^DGRPD,REG^IVMCQ($G(DFN))
23 . D EN^DGRPD
24 . Q:$G(DGRPOUT)
25 . ;
26 . ; ** start of VOE change 1 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
27 . ;
28 . ; HEC query call only wanted/needed for VA agency code
29 . ;
30 . I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN))
31 . ;
32 . ; ** end of VOE change 1 **
33 . ;
34 . D HINQ
35 ;
36A W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO
37 N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0)
38 ;
39 ;MPI QUERY
40 ;check to see if CIRN PD/MPI is installed
41 N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
42 K MPIFRTN
43 ;
44 ; ** start of VOE change 2 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
45 ;
46 ; MPI query call only wanted/needed for VA agency code
47 ;
48 I $G(DUZ("AG"))="V"!$$GET^XPAR("SYS","DG MPI") D MPIQ^MPIFAPI(DFN)
49 ;
50 ; ** end of VOE change 2 **
51 ;
52 K MPIFRTN
53 ;
54 I +$G(DGNEW) D
55 . ; query CMOR for Patient Record Flag Assignments if NEW patient and
56 . ; display results
57 . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
58 ;
59SKIP ;
60 S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A
61 ;
62 ; ** start of VOE change 3 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
63 ;
64 ; these query calls only wanted/needed for VA agency code
65 ;
66 I $G(DUZ("AG"))="V" D HINQ,REG^IVMCQ($G(DFN))
67 G A1
68 ;
69 ; ** end of VOE change 3 **
70 ;
71 ;
72HINQ ;
73 S Y=$S($D(^DG(43,1,0)):^(0),1:0) I $P(Y,U,27) S X="DVBHQZ4" X ^%ZOSF("TEST") I $T D
74 .N DGROUT
75 .S DGROUT=X
76 .I $G(DFN) D
77 ..N X,Y,DGRP
78 ..F X=.3,.32 S DGRP(X)=$G(^DPT(DFN,X))
79 ..W !," Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
80 ..W ?40," Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
81 .D @("EN^"_DGROUT) K Y Q ;from dgdem0
82 Q
83 ;
84 ; SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management
85 ; to bypass the embossing routines when calling load/edit from IEMM
86 ;
87A1 D G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP,MT(DFN),CP G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) G Q:'$D(DA),EMBOS
88 .W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data"
89 .S %=1 D YN^DICN
90 .I +$G(DGNEW) Q
91 .I $$ADD^DGADDUTL($G(DFN)) ;
92 ;
93H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing."
94 G A1
95 ;
96CK S DGEDCN=1 D ^DGRPC,MT(DFN),CP
97 G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM)
98 I $G(DGER)[55 K DIR S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? " D ^DIR K DIR
99 ;G:Y ^DGRP9
100 ;
101EMBOS ;W ! D EMBOS^DGQEMA G A
102 G A
103 ;
104 ;
105Q K X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,VET Q
106 ;
107MT(DFN) ; Check if user requires a means test. Ask user if they want to proceedif
108 ; one is required
109 I '$D(SDIEMM) DO
110 .N DGREQF,DIV
111 .D EN^DGMTR
112 .I DGREQF D EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R"
113 .Q
114 I $D(SDIEMM) DO
115 .N DGMTI
116 .S DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1)
117 .I $P(DGMTI,U,4)="R" D I 1
118 ..S DGMT0=$G(^DGMT(408.31,+DGMTI,0)),DGMTDT=$P(DGMT0,"^")
119 ..I '$$OKTOCONT(DGMTDT) Q
120 ..S DGMTI=+DGMTI,DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" D EN^DGMTSC
121 .E D WARNING
122 .Q
123 Q
124 ;
125WARNING ;
126 ;prints a warning to the screen about means test
127 ;
128 W !!,"A means test for this encounter date was not found and may be required!"
129 W !,"Further investigation will be needed."
130 W !
131 D PAUSE
132 Q
133 ;
134PAUSE ;
135 N DIR
136 S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR
137 Q
138 ;
139OKTOCONT(Y) ;
140 ;
141 N DIR
142 W !!,"Patient Requires a means Test"
143 X ^DD("DD")
144 W !,"Primary Means Test Required from '",Y,"'",!
145 ;
146 I $D(SDIEMM),'$D(^XUSEC("SCENI MEANS TEST EDIT",DUZ)) DO G OKQ
147 .W !,$C(7),"You do not have the appropriate IEMM Security Key. Contact your supervisor.",!
148 .D PAUSE
149 .S Y=0
150 ;
151 S DIR("A")="Do you wish to proceed with the means test at this time"
152 S DIR("B")="YES"
153 S DIR(0)="Y"
154 D ^DIR
155OKQ Q $S(Y=1:1,1:0)
156 ;
157CP ;If not (autoexempt or MTested) & no CP test this year then
158 ;prompt for add/edit cp test
159 N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT
160 G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG
161 S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT)
162 D EN^DGMTCOR
163 I +$G(DGNOCOPF) S DGMTCOR=0
164 I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT)
165 K DGNOCOPF
166QTCP Q
Note: See TracBrowser for help on using the repository browser.