source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXKMAIN1.m@ 1087

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

initial load of WorldVistAEHR
File size: 6.0 KB
RevLine 
[613]1PXKMAIN1 ;ISL/JVS,ISA/Zoltan - Main Routine for Data Capture ;5/6/1999
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**22,73,124,178**;Aug 12, 1996
3 ;+This routine is responsible for:
4 ;+ - creating new entries in PCE files,
5 ;+ - processing modifications to existing entries,
6 ;+ - deleting entries,
7 ;+ - ensuring all required variables are present,
8 ;+ - setting both Audit fields (EDITED FLAG and AUDIT TRAIL),
9 ;+ - checking for duplicate entries,
10 ;+ - some error reporting.
11 ;+
12 ;+LOCAL VARIABLE LIST
13 ;+ MOST VARIABLES ARE DEFINED AT THE TOP OF PXKMAIN
14 ;+ PXKSEQ = Sequence number in PXK tmp global
15 ;+ PXKCAT = Category of entry (CPT,MSR,VST...)
16 ;+ PXKREF = Root of temp global
17 ;+ PXKPIEN = IEN of v file
18 ;+ PXKAUDIT = data located in the audit field of the v file
19 ;+ PXKER = field data use to build the dr string (eg .04///^S X=$G()
20 ;+ PXKFLD = field number gleened from the file routines
21 ;+ PXKNOD = same as the subscript in a global node
22 ;+ PXKPCE = the piece where the data is found on that node
23 ;
24 ;
25 W !,"This is not an entry point" Q
26LOOP ;+Copy delimited strings into sub-arrays.
27 F PXKI=1:1:$L(PXKAFT(PXKSUB),"^") I $P(PXKAFT(PXKSUB),"^",PXKI)'="" S PXKAV(PXKSUB,PXKI)=$P(PXKAFT(PXKSUB),"^",PXKI)
28 F PXKI=1:1:$L(PXKBEF(PXKSUB),"^") I $P(PXKBEF(PXKSUB),"^",PXKI)'="" S PXKBV(PXKSUB,PXKI)=$P(PXKBEF(PXKSUB),"^",PXKI)
29 K PXKI,PXKJ ; Not sure if NEW would be OK.
30 I PXKCAT="CPT",PXKSUB=1 D LOOP^PXKMOD
31 Q
32 ;
33ERROR ;+Check for missing required fields
34 Q:$G(PXKAV(0,1))["@"!('$D(PXKAV(0,1)))
35 S PXKNOD=0,PXKPCE=0
36 D EN1^@PXKRTN
37 S PXKER=$P(PXKER," * ",1)
38 I PXKER="" Q
39 F PXJ=1:1:$L(PXKER,",") D
40 . S PXJJ=$P(PXKER,",",PXJ)
41 . I '$D(PXKAV(PXKNOD,PXJJ)) D
42 . . S PXKPCE=PXJJ
43 . . D EN2^@PXKRTN
44 . . S PXKFLD=$P(PXKFD,"/",1)
45 . . S:PXKFLD["*" PXKFLD=$P(PXKFLD," * ",2)
46 . . S PXKERROR(PXKCAT,PXKSEQ,0,PXKFLD)="Missing Required Fields"
47 K PXK,PXJJ,PXKFLD,PXKFD ; Not sure about use of NEW here.
48 Q
49 ;
50CLEAN ;--Clean out the PXKAV array
51 S PXKJ=""
52 F S PXKJ=$O(PXKBV(PXKJ)) Q:PXKJ="" D
53 . S PXKI=""
54 . F S PXKI=$O(PXKBV(PXKJ,PXKI)) Q:PXKI="" D
55 . . I $G(PXKBV(PXKJ,PXKI))=$G(PXKAV(PXKJ,PXKI)) K PXKAV(PXKJ,PXKI)
56 K PXKI,PXKJ ; Not sure about NEW here.
57 Q
58 ;
59FILE ;+Create a new entry in file and get IEN
60 ;+This is the code that adds new entries to V-files
61 ;+and to the Visit file.
62 K DD,DO
63 S DIC=$P($T(GLOBAL^@PXKRTN),";;",2)_"("
64 S DIC(0)=""
65 S X=$G(PXKAV(0,1))
66 D FILE^DICN
67 S (PXKPIEN,DA)=+Y
68 S DR=""
69 K DIC,Y,X
70 Q
71 ;
72AUD12 ;--Set both audit fields
73 S DR=""
74 S PXKAUDIT=$P($T(GLOBAL^@PXKRTN),";;",2)_"(DA,801)"
75 S PXKAUDIT=$P($G(@PXKAUDIT),"^",2)_PXKSORR_";"
76 I $L(PXKAUDIT,";")>5 S $P(PXKAUDIT,";",2,$L(PXKAUDIT,";"))="+;"_$P(PXKAUDIT,";",4,$L(PXKAUDIT,";")) ;PX*1*124 Change 8 to 5
77 S PXKNOD=801
78 S DR=""
79 F PXKPCE=1,2 D EN1^@PXKRTN S DR=DR_PXKER
80 S PXKFVDLM=""
81 Q
82 ;
83AUD2 ;--Set second audit fields
84 S DR=""
85 S PXKAUDIT=$P($T(GLOBAL^@PXKRTN),";;",2)_"(DA,801)"
86 S PXKAUDIT=$P($G(@PXKAUDIT),"^",2)_PXKSORR_";"
87 I $L(PXKAUDIT,";")>5 S $P(PXKAUDIT,";",2,$L(PXKAUDIT,";"))="+;"_$P(PXKAUDIT,";",4,$L(PXKAUDIT,";")) ;PX*1*124 Change 8 to 5
88 S PXKNOD=801
89 S DR=""
90 S PXKPCE=2
91 D EN1^@PXKRTN
92 S DR=DR_PXKER
93 S PXKFVDLM=""
94 Q
95 ;
96DRDIE ;--Set the DR string and DO DIE
97 I PXKCAT="VST" D UPD^PXKFVST Q
98 S DIE=$P($T(GLOBAL^@PXKRTN),";;",2)_"(" K PXKPTR
99 S PXKLR=$P($T(GLOBAL^@PXKRTN),";;",2)_"(DA)"
100 S PXKNOD=""
101 F S PXKNOD=$O(PXKAV(PXKNOD)) Q:PXKNOD="" D
102 . I PXKFGAD=1,PXKNOD=0 S PXKPCE=1 D
103 .. Q:PXKCAT'="CPT"
104 .. I $G(^TMP("PXK",$J,PXKCAT,PXKSEQ,"IEN"))=PXKPIEN S PXKPCE=3
105 . I PXKFGAD=1,PXKNOD'=0 S PXKPCE=0
106 . I PXKFGED=1 S PXKPCE=0
107 . I PXKCAT="CPT",PXKNOD=1 D Q
108 .. D DIE
109 .. I $G(^TMP("PXK",$J,PXKCAT,PXKSEQ,"IEN"))]"" Q
110 .. D UPD^PXKMOD
111 . F S PXKPCE=$O(PXKAV(PXKNOD,PXKPCE)) Q:PXKPCE="" D
112 ..D EN1^@PXKRTN
113 ..I $G(PXKER)'="" D
114 ...I PXKER["~" D
115 ....I $P(PXKER,"~",2)["A",PXKFGAD=1 S PXKER=$P(PXKER,"~") Q
116 ....I $P(PXKER,"~",2)'["A",PXKFGAD=1 S PXKER="" Q
117 ....I $P(PXKER,"~",2)["E",PXKFGED=1 S PXKER=$P(PXKER,"~") Q
118 ....I $P(PXKER,"~",2)'["E",PXKFGED=1 S PXKER="" Q
119 ...I +PXKER=0 D
120 ....I PXKAV(PXKNOD,PXKPCE)=+PXKAV(PXKNOD,PXKPCE) S PXKER=$P(PXKER," * ",2)
121 ....I PXKAV(PXKNOD,PXKPCE)'=+PXKAV(PXKNOD,PXKPCE) S PXKER=$P(PXKER," * ",3),PXKPTR(PXKPIEN,PXKNOD,PXKPCE)=""
122 ..I $G(PXKER)'="" S DR=DR_PXKER_"PXKAV("_PXKNOD_","_PXKPCE_"));"
123 ..I $L(DR)>200 D DIE
124 D DIE
125 K DIE,PXKLR,DIC(0)
126 D ER
127 Q
128DIE ;+Lock global and invoke FM ^DIE call.
129 L +@PXKLR:10
130 D ^DIE
131 L -@PXKLR
132 K DR
133 S DR=""
134 Q
135 ;
136DELETE ;+Use FM ^DIK call to delete entry identified by PXKPIEN.
137 S DA=PXKPIEN
138 S DIK=$P($T(GLOBAL^@PXKRTN),";;",2)_"("
139 D ^DIK
140 K DIK
141 Q
142 ;
143DUP ;+Code to check for duplicates
144 I PXKCAT="VST" Q
145 I PXKCAT="CPT" Q
146 I PXKCAT="HF" Q
147 N PXKRTN
148 I '$D(PXKPIEN) N PXKPIEN S PXKPIEN=""
149 S PXKNOD=0
150 S PXKPCE=0
151 S PXKRTN="PXKF"_PXKVCAT
152 S PXKVRTN=$P($T(GLOBAL^@PXKRTN),";;",2)
153 S PXJJJ=0
154 D EN1^@PXKRTN
155 I $P(PXKER," * ",3)'=0 D
156 .S PXKER=$P(PXKER," * ",2)
157 .I PXKER="" Q
158 .S (PX,PXFG)=0
159 .F S PX=$O(@PXKVRTN@("AD",PXKVST,PX)) Q:PX="" D Q:PXFG=1
160 ..S PXJJJ=0
161 ..F PXJ=1:1:$L(PXKER,",") S PXJJ=$P(PXKER,",",PXJ) D
162 ...I $P($G(@PXKVRTN@(PX,$P(PXJJ,"+",1))),"^",$P(PXJJ,"+",2))=$G(PXKAV($P(PXJJ,"+",1),$P(PXJJ,"+",2))),PX'=PXKPIEN S PXJJJ=PXJJJ+1
163 ..I $L(PXKER,",")=PXJJJ S PXFG=1
164 ;PXKHLR Is not killed because it is a flag comming from another routine
165 Q
166 ;
167ER ;--PXKERROR MAKING IF NOT POPULATED CORRECTLY
168 N PXKRT,PXKMOD,PXKSTR
169 S PXKMOD=PXKSEQ#1 I $G(PXKMOD) Q
170 S PXKN=""
171 F S PXKN=$O(PXKAV(PXKN)) Q:PXKN="" D
172 . S PXKP=""
173 . F S PXKP=$O(PXKAV(PXKN,PXKP)) Q:PXKP="" D
174 .. S PXKRRT=$P($T(GLOBAL^@PXKRTN),";;",2)_"("_DA_","
175 .. I PXKN=1,PXKCAT="CPT" S PXKRRT=PXKRRT_PXKN_","_PXKP_","_0_")"
176 .. E S PXKRRT=PXKRRT_PXKN_")"
177 .. I PXKAV(PXKN,PXKP)'=$P($G(@PXKRRT),"^",$S(PXKN=1:1,1:PXKP)) D
178 ... Q:PXKAV(PXKN,PXKP)["@"
179 ... S PXKNOD=PXKN,PXKPCE=PXKP
180 ... I PXKNOD=1,PXKCAT="CPT" S PXKPCE=1
181 ... D EN2^@PXKRTN
182 ... S PXKFLD=$P(PXKFD,"/",1)
183 ... S:PXKFLD["*" PXKFLD=$P(PXKFLD," * ",2)
184 ... Q:PXKFLD=1101
185 ... S PXKSTR="Not Stored = "_PXKAV(PXKN,PXKP)
186 ... I $G(PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD))]"" D
187 .... S PXKSTR=PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)_","_PXKAV(PXKN,PXKP)
188 ... S PXKERROR(PXKCAT,PXKSEQ,DA,PXKFLD)=PXKSTR
189 Q
Note: See TracBrowser for help on using the repository browser.