source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECMLMF.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1ECMLMF ;ALB/ESD - File Multiple Dates/Multiple Procedures - 29 AUG 97 08:51
2 ;;2.0; EVENT CAPTURE ;**5,10,15,13,17,18,23,42,54,72**;8 May 96
3 ;
4EN ;- Entry point to file selected patients and procedures
5 ;
6 N DIR,DIRUT,I,J,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
7 I '$D(^TMP("ECMPIDX",$J))!('$D(^TMP("ECMPTIDX",$J))) W !!,*7,"No patient data found. No patient record(s) have been filed." D MSG G ENQ
8 ;
9 W !!,"You have selected the following patients for filing:",!
10 ;
11 ;- List patients
12 S I=0
13 F S I=$O(^TMP("ECMPTIDX",$J,I)) Q:'I D
14 . W !?5,I_". ",$P($G(^TMP("ECMPTIDX",$J,I)),"^",3)
15 W !! S DIR(0)="YA",DIR("A")="Is this correct? ",DIR("B")="YES"
16 S DIR("?")="Answer YES to continue, NO to exit."
17 D ^DIR K DIR
18 I '$G(Y)!($D(DIRUT)) W !,"Exiting option...no patients filed.",! D MSG G ENQ
19 ;
20 ;- Task job
21 F J="DUZ","ECL","ECDSSU","ECCAT","ECU*" S ZTSAVE(J)=""
22 S ZTSAVE("^TMP(""ECMPIDX"",$J,")="",ZTSAVE("^TMP(""ECMPTIDX"",$J,")=""
23 S ZTIO="",ZTDESC="EC MULT DATES/MULT PROCS DATA ENTRY",ZTRTN="GETNODS^ECMLMF",ZTDTH=$H
24 ;
25 W !!,"These patients will be sent to the background for filing.",!
26 D ^%ZTLOAD
27 I $D(ZTSK) W !,"Queued as Task #",ZTSK,!
28 D MSG
29 ;
30ENQ K ^TMP("ECPLST",$J)
31 Q
32 ;
33 ;
34GETNODS ;- Get procedure node and patient node for processing
35 ;
36 N ECI,ECJ,ECPRNOD,ECPTNOD,ECDXX
37 S (ECI,ECJ)=0
38 F S ECI=$O(^TMP("ECMPTIDX",$J,ECI)) Q:'ECI D
39 . S ECPTNOD="",ECPTNOD=$G(^TMP("ECMPTIDX",$J,ECI))
40 . K ECDXX M ECDXX=^TMP("ECMPTIDX",$J,ECI,"DXS")
41 . F S ECJ=$O(^TMP("ECMPIDX",$J,ECJ)) Q:'ECJ D
42 .. S ECPRNOD="",ECPRNOD=$G(^TMP("ECMPIDX",$J,ECJ))
43 .. D FILREC
44 D ENQ^ECMLMD
45 S ZTREQ="@"
46 Q
47 ;
48 ;
49FILREC ;- Create record in #721 and file fields
50 ;
51 N DA,ECIEN,ECNOGO,ECPRR,ECPTR,ECREAS,ECSND,DIC,DLAYGO,DIE,DR,I,Y
52 S ECNOGO=0
53 S I=$P(^ECH(0),"^",3)
54LOCKHD S I=I+1 L +^ECH(I):2 I '$T!$D(^ECH(I)) L -^ECH(I) G LOCKHD
55 L -^ECH(0)
56 K DD,DO S X=I,DIC(0)="L",DLAYGO=721,DIC="^ECH(" D FILE^DICN
57 K DIC,DLAYGO,X
58 I Y=-1 G FILRECQ
59 S (ECIEN,DA)=+Y
60 L +^ECH(ECIEN):2 I '$T G FILRECQ
61 ;
62 D SETARRY
63 ;
64 ;- File zero node and "P" node
65 S DIE="^ECH(",DR="[EC CREATE PATIENT ENTRY]" D ^DIE K DR
66 ;
67 ;- File multiple providers, ALB/JAM
68 S ECFIL=$$FILPRV^ECPRVMUT(ECIEN,.ECU,.ECOUT) K ECFIL
69 ;- File secondary diagnoses codes, ALB/JAM
70 S (DXS,DXSIEN)=""
71 F S DXS=$O(ECDXX(DXS)) Q:DXS="" D
72 . S DXSIEN=+ECDXX(DXS) I DXSIEN<0 Q
73 . K DIC,DD,DO S DIC(0)="L",DA(1)=ECIEN,DIC("P")=$P(^DD(721,38,0),U,2)
74 . S X=DXSIEN,DIC="^ECH("_DA(1)_","_"""DX"""_"," D FILE^DICN
75 K DXS,DXSIEN,DIC
76 ;update encounter's procedures to have same primary & secondary dx
77 S PXUPD=$$PXUPD^ECUTL2(ECPTR("DFN"),ECPRR("PROCDT"),ECL,ECPTR("CLIN"),ECPTR("DX"),.ECDXX,ECIEN) K PXUPD
78 ;
79 ;File CPT modifiers, ALB/JAM
80 N MOD,MODIEN
81 S (ECMODS,MOD)=""
82 F S MOD=$O(^TMP("ECMPIDX",$J,ECJ,"MOD",MOD)) Q:MOD="" D
83 . S MODIEN=$P(^TMP("ECMPIDX",$J,ECJ,"MOD",MOD),U,2) I MODIEN<0 Q
84 . K DIC,DD,DO S DIC(0)="L",DA(1)=ECIEN,DIC("P")=$P(^DD(721,36,0),U,2)
85 . S X=MODIEN,DIC="^ECH("_DA(1)_","_"""MOD"""_"," D FILE^DICN
86 . S ECMODS=ECMODS_$S(ECMODS="":"",1:";")_MOD
87 ;
88 S ECSND=$P($G(^ECD(+$P($G(ECDSSU),"^"),0)),"^",14),DA=ECIEN
89 I ECSND="" S ECSND="N"
90 I ECSND="A"!((ECSND="O")&(ECPTR("IO")="O")) D
91 . S ECNOGO=$$BADFLDS(.ECREAS)
92 . I ECNOGO S DR="33////^S X=$G(ECREAS)" D ^DIE Q
93 . I 'ECNOGO D PCE
94 ;
95FILRECQ L -^ECH(ECIEN)
96 Q
97 ;
98 ;
99SETARRY ;- Set local arrays with procedure and patient data for filing
100 ;
101 N I
102 F I="PROCDT","PROC","REAS","VOL" S ECPRR(I)=$P(ECPRNOD,"^",+$P($T(@I),";;",2))
103 I ECPRR("REAS")=0 S ECPRR("REAS")=""
104 S I="PCEPR" S ECPRR(I)=$S($P($G(ECPRR("PROC")),";",2)="ICPT(":$P($G(ECPRR("PROC")),";"),1:$P($G(^EC(725,+$P($G(ECPRR("PROC")),";"),0)),"^",5))
105 F I="DFN","ORDSEC","IO","CLIN","DX","AO","ENV","IR","SC","ELIG","MST","HNC","CV" S ECPTR(I)=$P(ECPTNOD,"^",+$P($T(@I),";;",2))
106 Q
107 ;
108 ;
109BADFLDS(ECRS) ; - Validation checks on fields to be set in "PCE" node
110 ;
111 S ECRS=""
112 I ECPTR("CLIN")="" S ECRS="Clinic missing;"
113 I ECPTR("CLIN")=0 S ECRS="Clinic inactive;"
114 I ECPTR("DX")="" S ECRS=$G(ECRS)_"Diagnosis missing;"
115 I ECPRR("PCEPR")="" S ECRS=$G(ECRS)_"CPT code missing;"
116 Q $S($G(ECRS)="":0,1:1)
117 ;
118 ;
119PCE ;- More validation checks on fields to be set in "PCE" node
120 ;
121 N ECDSS,I,ECAO,ECELIG,ECEV,ECIR,ECSC,ECNP,ECNPP,ECPCENOD,ECMST,ECHNC,ECCV
122 G PCEQ:$G(ECPRR("PROCDT"))'["."!('$G(ECPRR("PCEPR")))
123 F I="DFN","CLIN","DX" G PCEQ:'$G(ECPTR(I))
124 G PCEQ:'$G(ECPRR("VOL"))
125 S ECDSS=$P($G(^ECH(ECIEN,0)),"^",20)
126 G PCEQ:'$G(ECL)!('ECDSS)!('$G(ECU(1)))
127 ;
128 S ECPTR("AO")=$G(ECPTR("AO"))
129 S ECAO=$S(ECPTR("AO")="Y":1,ECPTR("AO")="N":0,1:"")
130 ;
131 S ECPTR("ENV")=$G(ECPTR("ENV"))
132 S ECEV=$S(ECPTR("ENV")="Y":1,ECPTR("ENV")="N":0,1:"")
133 ;
134 S ECPTR("IR")=$G(ECPTR("IR"))
135 S ECIR=$S(ECPTR("IR")="Y":1,ECPTR("IR")="N":0,1:"")
136 ;
137 S ECPTR("SC")=$G(ECPTR("SC"))
138 S ECSC=$S(ECPTR("SC")="Y":1,ECPTR("SC")="N":0,1:"")
139 ;
140 S ECNPP="" I $G(ECPRR("PROC"))["EC" S ECNP=$G(^EC(725,+ECPRR("PROC"),0)),ECNPP=$P(ECNP,"^",2)_" "_$P(ECNP,"^",1)
141 ;
142 S ECELIG=$S($G(ECPTR("ELIG")):ECPTR("ELIG"),1:"")
143 ;
144 S ECPTR("MST")=$G(ECPTR("MST"))
145 S ECMST=$S(ECPTR("MST")="Y":1,ECPTR("MST")="N":0,1:"")
146 ;
147 ;JAM;09/30/02,Head/Neck Cancer
148 S ECPTR("HNC")=$G(ECPTR("HNC"))
149 S ECHNC=$S(ECPTR("HNC")="Y":1,ECPTR("HNC")="N":0,1:"")
150 ;
151 ;JAM;10/29/03,Combat Veteran
152 S ECPTR("CV")=$G(ECPTR("CV"))
153 S ECCV=$S(ECPTR("CV")="Y":1,ECPTR("CV")="N":0,1:"")
154 ;
155 ;JAM;06/01/05,Project 112/SHAD
156 ;S ECPTR("SHAD")=$G(ECPTR("SHAD"))
157 ;S ECSHAD=$S(ECPTR("SHAD")="Y":1,ECPTR("SHAD")="N":0,1:"")
158 ;- File "PCE" and "PCE1" nodes
159 ;
160 S DR="[EC FILE PCE NODE]" D ^DIE K DR
161 S DR="31////"_$$NOW^XLFDT D ^DIE
162PCEQ Q
163 ;
164 ;
165MSG ;- Message displayed so error message can be read on screen
166 ;
167 S DIR(0)="E" D ^DIR
168 Q
169 ;
170 ;- Subscripts used in creating ECPRR and ECPTR arrays
171 ;
172PROCDT ;;2
173PROC ;;3
174REAS ;;5
175VOL ;;7
176 ;
177DFN ;;2
178ORDSEC ;;4
179IO ;;5
180CLIN ;;6
181DX ;;8
182AO ;;10
183ENV ;;11
184IR ;;12
185SC ;;13
186ELIG ;;14
187MST ;;15
188HNC ;;16
189CV ;;17
Note: See TracBrowser for help on using the repository browser.