source: FOIAVistA/trunk/g/MAGD.zwr@ 1203

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

initial load of FOIAVistA 6/30/08 version
File size: 229.1 KB
Line 
1Globals from FOIA VistA with corrected Node problem for the cross references in the mental health files for C and AU
2Cache 13-Sep-2008 18:35:03 ZWR
3^MAGD(2006.5715,0)="CURRENT IMAGE^2006.5715^^"
4^MAGD(2006.575,0)="DICOM FAILED IMAGES^2006.575^^"
5^MAGD(2006.599,0)="DICOM Error Log^2006.599^^"
6^MAGD(2006.79,0)="DICOM ROUTINE COPY^2006.79^30^30"
7^MAGD(2006.79,1,0)="MCUIMAG0^3050311.125836"
8^MAGD(2006.79,1,1,0)="^2006.791^242^242"
9^MAGD(2006.79,1,1,1,0)="MCUIMAG0 ;HCIOFO/DAD-Create / Update Med Procedure with Image Pointer ;7/23/97 07:36"
10^MAGD(2006.79,1,1,2,0)=" ;;2.3;Medicine;**7,12**;09/13/1996"
11^MAGD(2006.79,1,1,3,0)=" Q"
12^MAGD(2006.79,1,1,4,0)=" ;"
13^MAGD(2006.79,1,1,5,0)="UPDATE(MCDATE,MCPROCD0,MCDFN,MCMAGPTR,MCD0,OK) ;"
14^MAGD(2006.79,1,1,6,0)=" ; *** Main driver to update Medicine files from Imaging ***"
15^MAGD(2006.79,1,1,7,0)=" ; MCDATE = Date/Time of procedure (FM internal format)"
16^MAGD(2006.79,1,1,8,0)=" ; MCPROCD0 = Pointer to the Procedure/Subspecialty file (#697.2)"
17^MAGD(2006.79,1,1,9,0)=" ; MCDFN = Pointer to the Patient file (#2)"
18^MAGD(2006.79,1,1,10,0)=" ; MCMAGPTR() = An array whose subscripts are pointers to the Image"
19^MAGD(2006.79,1,1,11,0)=" ; file (#2005) Returned as: MCMAGPTR(File 2005 IEN)="
20^MAGD(2006.79,1,1,12,0)=" ; MCFILE ^ MCD0 ^ MCD1 (IEN of image in image mult)"
21^MAGD(2006.79,1,1,13,0)=" ; MCD0 = Pointer to one of the Medicine Procedure data files"
22^MAGD(2006.79,1,1,14,0)=" ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news"
23^MAGD(2006.79,1,1,15,0)=" N DD,DIC,DINUM,DO,MCPATFLD,X,Y"
24^MAGD(2006.79,1,1,16,0)=" S MCDATE=+$G(MCDATE),MCPROCD0=+$G(MCPROCD0)"
25^MAGD(2006.79,1,1,17,0)=" S MCDFN=+$G(MCDFN),MCD0=+$G(MCD0)"
26^MAGD(2006.79,1,1,18,0)=" S MCFILE=+$P($P($G(^MCAR(697.2,MCPROCD0,0)),U,2),""("",2)"
27^MAGD(2006.79,1,1,19,0)=" I MCFILE'>0 D Q"
28^MAGD(2006.79,1,1,20,0)=" . S OK=""0^Medicine Procedure file global location not found"""
29^MAGD(2006.79,1,1,21,0)=" . Q"
30^MAGD(2006.79,1,1,22,0)=" S MCPATFLD=$$PATFLD(MCFILE)"
31^MAGD(2006.79,1,1,23,0)=" I MCPATFLD'>0 D Q"
32^MAGD(2006.79,1,1,24,0)=" . S OK=""0^Medical Patient field not found in Medicine Procedure file"""
33^MAGD(2006.79,1,1,25,0)=" . Q"
34^MAGD(2006.79,1,1,26,0)=" I MCD0>0 S OK=$$VALID(MCFILE,MCD0,MCDFN,MCPROCD0) Q:'OK"
35^MAGD(2006.79,1,1,27,0)=" I MCD0'>0 D Q:'OK"
36^MAGD(2006.79,1,1,28,0)=" . N MCIEN S MCIEN=0"
37^MAGD(2006.79,1,1,29,0)=" . F S MCIEN=$O(^MCAR(MCFILE,""B"",MCDATE,MCIEN)) Q:MCIEN'>0 D Q:MCD0"
38^MAGD(2006.79,1,1,30,0)=" .. S OK=$$VALID(MCFILE,MCIEN,MCDFN,MCPROCD0)"
39^MAGD(2006.79,1,1,31,0)=" .. I OK S MCD0=MCIEN"
40^MAGD(2006.79,1,1,32,0)=" .. Q"
41^MAGD(2006.79,1,1,33,0)=" . I MCD0'>0 D NEW(MCDATE,MCDFN,MCFILE,MCPROCD0,MCPATFLD,.MCD0,.OK)"
42^MAGD(2006.79,1,1,34,0)=" . Q"
43^MAGD(2006.79,1,1,35,0)=" I $O(MCMAGPTR(0)) D FILE(MCD0,MCFILE,.MCMAGPTR,.OK) Q:'OK"
44^MAGD(2006.79,1,1,36,0)=" S MCD0=MCD0_U_MCFILE"
45^MAGD(2006.79,1,1,37,0)=" Q"
46^MAGD(2006.79,1,1,38,0)=" ;"
47^MAGD(2006.79,1,1,39,0)="NEW(MCDATE,MCDFN,MCFILE,MCPROCD0,MCPATFLD,MCD0,OK) ;"
48^MAGD(2006.79,1,1,40,0)=" ; *** Create new Medicine patient (if needed) and procedure records ***"
49^MAGD(2006.79,1,1,41,0)=" ; MCDATE = Date/Time of procedure (FM internal format)"
50^MAGD(2006.79,1,1,42,0)=" ; MCDFN = Pointer to the Patient file (#2)"
51^MAGD(2006.79,1,1,43,0)=" ; MCFILE = File number of one of the Medicine Procedure data files"
52^MAGD(2006.79,1,1,44,0)=" ; MCPROCD0 = Pointer to the Procedure/Subspecialty file (#697.2)"
53^MAGD(2006.79,1,1,45,0)=" ; MCPATFLD = Field# in one of the Medicine Procedure data files"
54^MAGD(2006.79,1,1,46,0)=" ; that points to the Medical Patient file (#690)"
55^MAGD(2006.79,1,1,47,0)=" ; MCD0 = Pointer to one of the Medicine Procedure data files"
56^MAGD(2006.79,1,1,48,0)=" ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news"
57^MAGD(2006.79,1,1,49,0)=" N DD,DIC,DINUM,DLAYGO,DO,MCARCODE,MCPRCFLD,MCRESULT,X,Y"
58^MAGD(2006.79,1,1,50,0)=" S OK=""1^New stub record created in Medicine Procedure data file"""
59^MAGD(2006.79,1,1,51,0)=" ; *** Create a new record in the Medical Patient file (#690) ***"
60^MAGD(2006.79,1,1,52,0)=" I '$D(^MCAR(690,MCDFN)) D Q:'OK"
61^MAGD(2006.79,1,1,53,0)=" . K DD,DIC,DINUM,DO"
62^MAGD(2006.79,1,1,54,0)=" . S (X,DINUM)=MCDFN,DLAYGO=690"
63^MAGD(2006.79,1,1,55,0)=" . S DIC=""^MCAR(690,"",DIC(0)=""L"""
64^MAGD(2006.79,1,1,56,0)=" . D FILE^DICN"
65^MAGD(2006.79,1,1,57,0)=" . I Y'>0 D"
66^MAGD(2006.79,1,1,58,0)=" .. S OK=""0^Cannot add patient to Medical Patient file"""
67^MAGD(2006.79,1,1,59,0)=" .. Q"
68^MAGD(2006.79,1,1,60,0)=" . Q"
69^MAGD(2006.79,1,1,61,0)=" ; *** Create a stub record ***"
70^MAGD(2006.79,1,1,62,0)=" K DD,DIC,DINUM,DO"
71^MAGD(2006.79,1,1,63,0)=" S DIC=$$GET1^DID(MCFILE,"""","""",""GLOBAL NAME"")"
72^MAGD(2006.79,1,1,64,0)=" S DIC(0)=""L"",DLAYGO=MCFILE"
73^MAGD(2006.79,1,1,65,0)=" S DIC(""DR"")=MCPATFLD_""///`""_MCDFN"
74^MAGD(2006.79,1,1,66,0)=" S MCARCODE=$P($G(^MCAR(697.2,MCPROCD0,0)),U,4) S:MCARCODE="""" MCARCODE=U"
75^MAGD(2006.79,1,1,67,0)=" S MCPRCFLD=$$PRCFLD(MCFILE)"
76^MAGD(2006.79,1,1,68,0)=" I MCPRCFLD>0 D PRCSUBS Q:'OK"
77^MAGD(2006.79,1,1,69,0)=" S X=MCDATE"
78^MAGD(2006.79,1,1,70,0)=" D FILE^DICN S MCD0=+Y"
79^MAGD(2006.79,1,1,71,0)=" I MCD0'>0 D"
80^MAGD(2006.79,1,1,72,0)=" . S OK=""0^Cannot create stub record in the Medicine Procedure data file"""
81^MAGD(2006.79,1,1,73,0)=" . Q"
82^MAGD(2006.79,1,1,74,0)=" Q"
83^MAGD(2006.79,1,1,75,0)=" ;"
84^MAGD(2006.79,1,1,76,0)="FILE(MCD0,MCFILE,MCMAGPTR,OK) ;"
85^MAGD(2006.79,1,1,77,0)=" ; *** Store the Image file (#2005) pointers in Med Proc data files ***"
86^MAGD(2006.79,1,1,78,0)=" ; MCD0 = Pointer to one of the Medicine Procedure data files"
87^MAGD(2006.79,1,1,79,0)=" ; MCFILE = File number of one of the Medicine Procedure data files"
88^MAGD(2006.79,1,1,80,0)=" ; MCMAGPTR() = An array whose subscripts are pointers to the Image"
89^MAGD(2006.79,1,1,81,0)=" ; file (#2005) Returned as: MCMAGPTR(File 2005 IEN)="
90^MAGD(2006.79,1,1,82,0)=" ; MCFILE ^ MCD0 ^ MCD1 (IEN of image in image mult)"
91^MAGD(2006.79,1,1,83,0)=" ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news"
92^MAGD(2006.79,1,1,84,0)=" N DD,DIC,DINUM,DLAYGO,DO,MCD1,MCDIC,MCMAGD0,MCNODE,X,Y"
93^MAGD(2006.79,1,1,85,0)=" S OK=""1^The Medicine Procedure file has been updated"""
94^MAGD(2006.79,1,1,86,0)=" I $O(MCMAGPTR(0))'>0 D Q"
95^MAGD(2006.79,1,1,87,0)=" . S OK=""0^No image number to file in Medicine Procedure file"""
96^MAGD(2006.79,1,1,88,0)=" . Q"
97^MAGD(2006.79,1,1,89,0)=" I $$VFIELD^DILFD(MCFILE,2005)'>0 D Q"
98^MAGD(2006.79,1,1,90,0)=" . S OK=""0^Image field not found in the Medicine Procedure file"""
99^MAGD(2006.79,1,1,91,0)=" . Q"
100^MAGD(2006.79,1,1,92,0)=" S MCNODE=$P($$GET1^DID(MCFILE,2005,"""",""GLOBAL SUBSCRIPT LOCATION""),"";"")"
101^MAGD(2006.79,1,1,93,0)=" I MCNODE="""" D Q"
102^MAGD(2006.79,1,1,94,0)=" . S OK=""0^Medicine Procedure file global subscript location not found"""
103^MAGD(2006.79,1,1,95,0)=" . Q"
104^MAGD(2006.79,1,1,96,0)=" S MCDIC=$$GET1^DID(MCFILE,"""","""",""GLOBAL NAME"")_MCD0_"","""
105^MAGD(2006.79,1,1,97,0)=" S MCDIC=MCDIC_$S(MCNODE=+MCNODE:MCNODE,1:""""""""_MCNODE_"""""""")_"","""
106^MAGD(2006.79,1,1,98,0)=" S MCDIC(""P"")=$$GET1^DID(MCFILE,2005,"""",""SPECIFIER"")"
107^MAGD(2006.79,1,1,99,0)=" S MCMAGD0=0"
108^MAGD(2006.79,1,1,100,0)=" F S MCMAGD0=$O(MCMAGPTR(MCMAGD0)) Q:MCMAGD0'>0 D Q:'OK"
109^MAGD(2006.79,1,1,101,0)=" . S MCD1=+$O(^MCAR(MCFILE,MCD0,MCNODE,""B"",MCMAGD0,0))"
110^MAGD(2006.79,1,1,102,0)=" . I MCMAGD0'=$P($G(^MCAR(MCFILE,MCD0,MCNODE,MCD1,0)),U) S MCD1=0"
111^MAGD(2006.79,1,1,103,0)=" . K DD,DIC,DINUM,DO"
112^MAGD(2006.79,1,1,104,0)=" . S DIC=MCDIC,DIC(0)=""L"",DIC(""P"")=MCDIC(""P"")"
113^MAGD(2006.79,1,1,105,0)=" . S DLAYGO=MCFILE,(D0,DA(1))=MCD0"
114^MAGD(2006.79,1,1,106,0)=" . S X=MCMAGD0"
115^MAGD(2006.79,1,1,107,0)=" . I MCD1'>0 D"
116^MAGD(2006.79,1,1,108,0)=" .. D FILE^DICN S MCD1=+Y"
117^MAGD(2006.79,1,1,109,0)=" .. I MCD1'>0 S OK=""0^Cannot add image to Medicine Procedure file"""
118^MAGD(2006.79,1,1,110,0)=" .. Q"
119^MAGD(2006.79,1,1,111,0)=" . I OK S MCMAGPTR(MCMAGD0)=MCFILE_U_MCD0_U_MCD1"
120^MAGD(2006.79,1,1,112,0)=" . Q"
121^MAGD(2006.79,1,1,113,0)=" Q"
122^MAGD(2006.79,1,1,114,0)=" ;"
123^MAGD(2006.79,1,1,115,0)="VALID(FILE,IEN,DFN,PRC) ;"
124^MAGD(2006.79,1,1,116,0)=" ; *** Make sure we have the right Medicine Procedure data file rec ***"
125^MAGD(2006.79,1,1,117,0)=" ; FILE = File number of one of the Medicine Procedure data files"
126^MAGD(2006.79,1,1,118,0)=" ; IEN = Pointer to one of the Medicine Procedure data files"
127^MAGD(2006.79,1,1,119,0)=" ; DFN = Pointer to the Patient file (#2)"
128^MAGD(2006.79,1,1,120,0)=" ; PRC = Pointer to the Procedure/Subspecialty file (#697.2)"
129^MAGD(2006.79,1,1,121,0)=" ; Returns"
130^MAGD(2006.79,1,1,122,0)=" ; '1^Message' = All is well, '0^Message' = Bad news"
131^MAGD(2006.79,1,1,123,0)=" N FIELD,OK,TYPE"
132^MAGD(2006.79,1,1,124,0)=" S OK=""1^Record match found"""
133^MAGD(2006.79,1,1,125,0)=" S FIELD=$$PATFLD(FILE)"
134^MAGD(2006.79,1,1,126,0)=" I FIELD,$$GET1^DIQ(FILE,IEN,FIELD,""I"")'=DFN D"
135^MAGD(2006.79,1,1,127,0)=" . S OK=""0^Patient mismatch"""
136^MAGD(2006.79,1,1,128,0)=" . Q"
137^MAGD(2006.79,1,1,129,0)=" S FIELD=$$PRCFLD(FILE),TYPE=$$PRCTYPE(PRC)"
138^MAGD(2006.79,1,1,130,0)=" ; *** Old Generalized Procedures module and other modules"
139^MAGD(2006.79,1,1,131,0)=" I (MCFILE'=699.5)!((MCFILE=699.5)&($$VFILE^DILFD(MCFILE,.06)'>0)) D"
140^MAGD(2006.79,1,1,132,0)=" . S FIELD=$P(FIELD,U)"
141^MAGD(2006.79,1,1,133,0)=" . Q"
142^MAGD(2006.79,1,1,134,0)=" ; *** New Generalized Procedures module"
143^MAGD(2006.79,1,1,135,0)=" I (MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)>0) D"
144^MAGD(2006.79,1,1,136,0)=" . S FIELD=$S(TYPE=""S"":$P(FIELD,U),TYPE=""P"":$P(FIELD,U,2),1:0)"
145^MAGD(2006.79,1,1,137,0)=" . Q"
146^MAGD(2006.79,1,1,138,0)=" I FIELD,$$GET1^DIQ(FILE,IEN,FIELD,""I"")'=PRC D"
147^MAGD(2006.79,1,1,139,0)=" . S OK=""0^Procedure/Subspecialty mismatch"""
148^MAGD(2006.79,1,1,140,0)=" . Q"
149^MAGD(2006.79,1,1,141,0)=" Q OK"
150^MAGD(2006.79,1,1,142,0)=" ;"
151^MAGD(2006.79,1,1,143,0)="PRCFLD(FILE) ;"
152^MAGD(2006.79,1,1,144,0)=" ; *** Procedure/Subspecialty pointer field ***"
153^MAGD(2006.79,1,1,145,0)=" ; FILE = File number of one of the Medicine Procedure data files"
154^MAGD(2006.79,1,1,146,0)=" ; Returns"
155^MAGD(2006.79,1,1,147,0)=" ; The field# in one of the Medicine Procedure data files that points"
156^MAGD(2006.79,1,1,148,0)=" ; to the Procedure/Subspecialty file (#690) (Zero [0] if not found)"
157^MAGD(2006.79,1,1,149,0)=" N PRCFLD"
158^MAGD(2006.79,1,1,150,0)=" S PRCFLD(694)=2,PRCFLD(694.8)=9,PRCFLD(699)=1,PRCFLD(699.5)="".05^.06"""
159^MAGD(2006.79,1,1,151,0)=" Q $G(PRCFLD(FILE),0)"
160^MAGD(2006.79,1,1,152,0)=" ;"
161^MAGD(2006.79,1,1,153,0)="PATFLD(FILE) ;"
162^MAGD(2006.79,1,1,154,0)=" ; *** Medical Patient pointer field ***"
163^MAGD(2006.79,1,1,155,0)=" ; FILE = File number of one of the Medicine Procedure data files"
164^MAGD(2006.79,1,1,156,0)=" ; Returns"
165^MAGD(2006.79,1,1,157,0)=" ; The field# in one of the Medicine Procedure data files that points"
166^MAGD(2006.79,1,1,158,0)=" ; to the Medical Patient file (#690) (Zero [0] if not found)"
167^MAGD(2006.79,1,1,159,0)=" N MEDPAT"
168^MAGD(2006.79,1,1,160,0)=" S MEDPAT(691)=1,MEDPAT(691.1)=1,MEDPAT(691.5)=1,MEDPAT(691.6)=1"
169^MAGD(2006.79,1,1,161,0)=" S MEDPAT(691.7)=1,MEDPAT(691.8)=1,MEDPAT(694)=1,MEDPAT(694.5)=1"
170^MAGD(2006.79,1,1,162,0)=" S MEDPAT(698)=1,MEDPAT(698.1)=1,MEDPAT(698.2)=1,MEDPAT(698.3)=1"
171^MAGD(2006.79,1,1,163,0)=" S MEDPAT(699)=.02,MEDPAT(699.5)=.02,MEDPAT(700)=1,MEDPAT(701)=1"
172^MAGD(2006.79,1,1,164,0)=" Q $G(MEDPAT(FILE),0)"
173^MAGD(2006.79,1,1,165,0)=" ;"
174^MAGD(2006.79,1,1,166,0)="PRCSUBS ; *** Procedure/Subspecialty DIC(""DR"") builder ***"
175^MAGD(2006.79,1,1,167,0)=" ; *** Old Generalized Procedures module and other modules"
176^MAGD(2006.79,1,1,168,0)=" N MCGENPRC,MCGENSUB,MCPRCTYP"
177^MAGD(2006.79,1,1,169,0)=" I (MCFILE'=699.5)!((MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)'>0)) D"
178^MAGD(2006.79,1,1,170,0)=" . D PRCTEST(MCFILE,$P(MCPRCFLD,U),MCPROCD0,.OK)"
179^MAGD(2006.79,1,1,171,0)=" . S DIC(""DR"")=DIC(""DR"")_"";""_$P(MCPRCFLD,U)_""///`""_MCPROCD0"
180^MAGD(2006.79,1,1,172,0)=" . Q"
181^MAGD(2006.79,1,1,173,0)=" ; *** New Generalized Procedures module"
182^MAGD(2006.79,1,1,174,0)=" I (MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)>0) D"
183^MAGD(2006.79,1,1,175,0)=" . S MCGENPRC=$$FINDPRC(""GENERIC PROCEDURE"",""P"")"
184^MAGD(2006.79,1,1,176,0)=" . I MCGENPRC'>0 S OK=""0^Entry 'GENERIC PROCEDURE' not found"" Q"
185^MAGD(2006.79,1,1,177,0)=" . S MCGENSUB=$$FINDPRC(""GENERIC SUBSPECIALTY"",""S"")"
186^MAGD(2006.79,1,1,178,0)=" . I MCGENSUB'>0 S OK=""0^Entry 'GENERIC SUBSPECIALTY' not found"" Q"
187^MAGD(2006.79,1,1,179,0)=" . S MCPRCTYP=$$PRCTYPE(MCPROCD0)"
188^MAGD(2006.79,1,1,180,0)=" . I ""^P^S^""'[(U_MCPRCTYP_U) S OK=""0^Invalid Procedure/Subspecialty"" Q"
189^MAGD(2006.79,1,1,181,0)=" . D PRCTEST(MCFILE,$P(MCPRCFLD,U,$TR(MCPRCTYP,""PS"",""21"")),MCPROCD0,.OK)"
190^MAGD(2006.79,1,1,182,0)=" . I MCPRCTYP=""P"" D"
191^MAGD(2006.79,1,1,183,0)=" .. S DIC(""DR"")=DIC(""DR"")_"";""_$P(MCPRCFLD,U)_""///`""_MCGENSUB"
192^MAGD(2006.79,1,1,184,0)=" .. S DIC(""DR"")=DIC(""DR"")_"";""_$P(MCPRCFLD,U,2)_""///`""_MCPROCD0"
193^MAGD(2006.79,1,1,185,0)=" .. Q"
194^MAGD(2006.79,1,1,186,0)=" . I MCPRCTYP=""S"" D"
195^MAGD(2006.79,1,1,187,0)=" .. S DIC(""DR"")=DIC(""DR"")_"";""_$P(MCPRCFLD,U)_""///`""_MCPROCD0"
196^MAGD(2006.79,1,1,188,0)=" .. S DIC(""DR"")=DIC(""DR"")_"";""_$P(MCPRCFLD,U,2)_""///`""_MCGENPRC"
197^MAGD(2006.79,1,1,189,0)=" .. Q"
198^MAGD(2006.79,1,1,190,0)=" . Q"
199^MAGD(2006.79,1,1,191,0)=" Q"
200^MAGD(2006.79,1,1,192,0)=" ;"
201^MAGD(2006.79,1,1,193,0)="PRCTEST(MCFILE,MCPRCFLD,MCPROCD0,OK) ;"
202^MAGD(2006.79,1,1,194,0)=" ; *** Test for valid procedure"
203^MAGD(2006.79,1,1,195,0)=" N MCRESULT"
204^MAGD(2006.79,1,1,196,0)=" D CHK^DIE(MCFILE,MCPRCFLD,"""",""`""_MCPROCD0,.MCRESULT)"
205^MAGD(2006.79,1,1,197,0)=" K ^TMP(""DIERR"",$J)"
206^MAGD(2006.79,1,1,198,0)=" I MCRESULT=U S OK=""0^Procedure is invalid"""
207^MAGD(2006.79,1,1,199,0)=" Q"
208^MAGD(2006.79,1,1,200,0)=" ;"
209^MAGD(2006.79,1,1,201,0)="PRCTYPE(MCPROCD0) ;"
210^MAGD(2006.79,1,1,202,0)=" ; *** Return the procedure type ***"
211^MAGD(2006.79,1,1,203,0)=" Q $P($G(^MCAR(697.2,MCPROCD0,1)),U)"
212^MAGD(2006.79,1,1,204,0)=" ;"
213^MAGD(2006.79,1,1,205,0)="FINDPRC(MCENTRY,MCTYPE) ;"
214^MAGD(2006.79,1,1,206,0)=" ; *** Find a procedure ***"
215^MAGD(2006.79,1,1,207,0)=" ; MCENTRY = External name of the entry (697.2,.01)"
216^MAGD(2006.79,1,1,208,0)=" ; MCTYPE = Internal 'Procedure/Subspecialty' type (697.2,1001)"
217^MAGD(2006.79,1,1,209,0)=" ; Returns"
218^MAGD(2006.79,1,1,210,0)=" ; The IEN of the procedure or zero if not found."
219^MAGD(2006.79,1,1,211,0)=" N MCFOUND,MCIEN"
220^MAGD(2006.79,1,1,212,0)=" S (MCIEN,MCFOUND)=0"
221^MAGD(2006.79,1,1,213,0)=" F S MCIEN=$O(^MCAR(697.2,""B"",MCENTRY,MCIEN)) Q:MCIEN'>0 D Q:MCFOUND"
222^MAGD(2006.79,1,1,214,0)=" . I $P($G(^MCAR(697.2,MCIEN,0)),U)=MCENTRY D"
223^MAGD(2006.79,1,1,215,0)=" .. I $P($G(^MCAR(697.2,MCIEN,1)),U)=MCTYPE S MCFOUND=1"
224^MAGD(2006.79,1,1,216,0)=" .. Q"
225^MAGD(2006.79,1,1,217,0)=" . Q"
226^MAGD(2006.79,1,1,218,0)=" Q +MCIEN"
227^MAGD(2006.79,1,1,219,0)=" ;"
228^MAGD(2006.79,1,1,220,0)="KILL(MCFILE,MCD0,MCD1,OK) ;"
229^MAGD(2006.79,1,1,221,0)=" ; *** Remove an image from Image multiple ***"
230^MAGD(2006.79,1,1,222,0)=" ; MCFILE = A Medicine Procedure data file number"
231^MAGD(2006.79,1,1,223,0)=" ; MCD0 = Pointer to one of the Medicine Procedure data files"
232^MAGD(2006.79,1,1,224,0)=" ; MCD1 = Pointer to one of the entries in the in the Image multiple"
233^MAGD(2006.79,1,1,225,0)=" ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news"
234^MAGD(2006.79,1,1,226,0)=" N D0,D1,DA,DIK,MCNODE"
235^MAGD(2006.79,1,1,227,0)=" S OK=""1^Image pointer deleted from Medicine Procedure file"""
236^MAGD(2006.79,1,1,228,0)=" I $$VFIELD^DILFD(MCFILE,2005)'>0 D Q"
237^MAGD(2006.79,1,1,229,0)=" . S OK=""0^Image field not found in the Medicine Procedure file"""
238^MAGD(2006.79,1,1,230,0)=" . Q"
239^MAGD(2006.79,1,1,231,0)=" S DIK=$$GET1^DID(MCFILE,"""","""",""GLOBAL NAME"")"
240^MAGD(2006.79,1,1,232,0)=" I DIK="""" D Q"
241^MAGD(2006.79,1,1,233,0)=" . S OK=""0^Medicine Procedure file global name not found"""
242^MAGD(2006.79,1,1,234,0)=" . Q"
243^MAGD(2006.79,1,1,235,0)=" S MCNODE=$P($$GET1^DID(MCFILE,2005,"""",""GLOBAL SUBSCRIPT LOCATION""),"";"")"
244^MAGD(2006.79,1,1,236,0)=" I MCNODE="""" D Q"
245^MAGD(2006.79,1,1,237,0)=" . S OK=""0^Medicine Procedure file global subscript location not found"""
246^MAGD(2006.79,1,1,238,0)=" . Q"
247^MAGD(2006.79,1,1,239,0)=" S DIK=DIK_MCD0_"",""_$S(MCNODE=+MCNODE:MCNODE,1:""""""""_MCNODE_"""""""")_"","""
248^MAGD(2006.79,1,1,240,0)=" S (D0,DA(1))=MCD0,(D1,DA)=MCD1"
249^MAGD(2006.79,1,1,241,0)=" D ^DIK"
250^MAGD(2006.79,1,1,242,0)=" Q"
251^MAGD(2006.79,2,0)="RARIC^3050311.125836"
252^MAGD(2006.79,2,1,0)="^2006.791^80^80"
253^MAGD(2006.79,2,1,1,0)="RARIC ;HISC/FPT AISC/SAW-Radiologic Image Capture and Display Routine ;6/19/97 12:06"
254^MAGD(2006.79,2,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;**23,27**;Mar 16, 1998"
255^MAGD(2006.79,2,1,3,0)=" ;"
256^MAGD(2006.79,2,1,4,0)="CREATE ; create new stub entry in file 74"
257^MAGD(2006.79,2,1,5,0)=" ; called from ^MAGKEXC, ^MAGKEXC1"
258^MAGD(2006.79,2,1,6,0)=" ; If no report entry is created, RARPT will be undefined"
259^MAGD(2006.79,2,1,7,0)=" K RARPT"
260^MAGD(2006.79,2,1,8,0)=" ; --------------------------------------------------------------------"
261^MAGD(2006.79,2,1,9,0)=" ; Perform data validation checks for the following 'RA' namespaced"
262^MAGD(2006.79,2,1,10,0)=" ; variables: RADTE, RADFN, RADTI, RACN & RACNI (all should be defined)"
263^MAGD(2006.79,2,1,11,0)=" Q:'$D(RADTE)!('$D(RADFN))!('$D(RADTI))!('$D(RACN))!('$D(RACNI))"
264^MAGD(2006.79,2,1,12,0)=" ; Check the above variables to insure they consist of the proper"
265^MAGD(2006.79,2,1,13,0)=" ; sequence of characters."
266^MAGD(2006.79,2,1,14,0)=" Q:RADTE'?7N1"".""1.4N ; Fileman internal date/time without seconds"
267^MAGD(2006.79,2,1,15,0)=" K RASULT D DT^DILF(""T"",RADTE,.RASULT)"
268^MAGD(2006.79,2,1,16,0)=" I RASULT=-1 K RASULT Q ; invalid FM internal date format"
269^MAGD(2006.79,2,1,17,0)=" K RASULT"
270^MAGD(2006.79,2,1,18,0)=" Q:RADTI'?7N1"".""1.4N ; reverse chronological date/time without seconds"
271^MAGD(2006.79,2,1,19,0)=" Q:+RADFN'=RADFN Q:'$D(^RADPT(RADFN,0)) ; not a number, or invalid ien"
272^MAGD(2006.79,2,1,20,0)=" Q:RACN'?1.5N ; case #'s lie in the range of 1-99999"
273^MAGD(2006.79,2,1,21,0)=" Q:RACNI'?1N.N ; must be a number, period"
274^MAGD(2006.79,2,1,22,0)=" Q:'$D(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0)) ; exam record missing"
275^MAGD(2006.79,2,1,23,0)=" Q:$P(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0),U)'=RACN ; case/exam mismatch"
276^MAGD(2006.79,2,1,24,0)=" ; --------------------------------------------------------------------"
277^MAGD(2006.79,2,1,25,0)=" ; continue whether exam was purged or not -- 08/23/00"
278^MAGD(2006.79,2,1,26,0)=" N RAPRTSET,RAMEMARR,RA1"
279^MAGD(2006.79,2,1,27,0)=" D EN2^RAUTL20(.RAMEMARR) ; is this case part of a print set ?"
280^MAGD(2006.79,2,1,28,0)=" ; don't need to lock exam date's node"
281^MAGD(2006.79,2,1,29,0)=" N I,J,X S I=$P(^RARPT(0),""^"",3)"
282^MAGD(2006.79,2,1,30,0)="LOCK S I=I+1 L +^RARPT(I):1"
283^MAGD(2006.79,2,1,31,0)=" I $T,'$D(^RARPT(I)),'$D(^RARPT(""B"",I)) G NEWOK"
284^MAGD(2006.79,2,1,32,0)=" L -^RARPT(I)"
285^MAGD(2006.79,2,1,33,0)=" S X=$G(^RAPRT(I,0))"
286^MAGD(2006.79,2,1,34,0)=" ;"
287^MAGD(2006.79,2,1,35,0)=" ; if lock-failed node belongs to this case, set rarpt & quit"
288^MAGD(2006.79,2,1,36,0)=" I $P(X,""^"",2)=RADFN,(9999999.9999-$P(X,""^"",3))=RADTI,$P($P(X,""^""),""-"",2)=RACNI S RARPT=I G OUT"
289^MAGD(2006.79,2,1,37,0)=" ; if lock-failed node belongs to a printset with the same patient and "
290^MAGD(2006.79,2,1,38,0)=" ; exam date/time as the current case, set rarpt & quit"
291^MAGD(2006.79,2,1,39,0)=" I RAPRTSET,$P(X,""^"",2)=RADFN,(9999999.9999-$P(X,""^"",3))=RADTI S RARPT=I G OUT"
292^MAGD(2006.79,2,1,40,0)=" ;"
293^MAGD(2006.79,2,1,41,0)=" G LOCK ; lock-failed node belongs to another case, thus try again"
294^MAGD(2006.79,2,1,42,0)="NEWOK S ^RARPT(I,0)=$E(RADTE,4,7)_$E(RADTE,2,3)_""-""_RACN,RARPT=I,^(0)=$P(^RARPT(0),""^"",1,2)_""^""_I_""^""_($P(^(0),""^"",4)+1) D NOW^%DTC S DT=X K %,%H,%I"
295^MAGD(2006.79,2,1,43,0)=" ; don't define ""T"" node"
296^MAGD(2006.79,2,1,44,0)=" S $P(^RARPT(I,0),""^"",2,6)=RADFN_""^""_(9999999.9999-RADTI)_""^""_RACN_""^^""_DT ; don't stuff REPORTED DATE"
297^MAGD(2006.79,2,1,45,0)=" S:'$D(RAMDIV) RAMDIV=+$P(^RADPT(RADFN,""DT"",RADTI,0),""^"",3) S:'$D(RAMDV) RAMDV=$S($D(^RA(79,RAMDIV,.1)):^(.1),1:"""") S $P(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0),""^"",17)=RARPT"
298^MAGD(2006.79,2,1,46,0)=" S MAGSCN=$G(^MAG(2006.1,""AXSCN""))"
299^MAGD(2006.79,2,1,47,0)=" I ('MAGSCN)!(MAGSCN=""N"") S MAGSCN="""""
300^MAGD(2006.79,2,1,48,0)=" E S MAGSCN=""Images captured for this report."""
301^MAGD(2006.79,2,1,49,0)=" I $L(MAGSCN) S ^RARPT(RARPT,""R"",0)=""^^1^1^""_DT,^RARPT(RARPT,""R"",1,0)=MAGSCN"
302^MAGD(2006.79,2,1,50,0)=" ; The orig. clin hist is now referenced directly from file 70, so"
303^MAGD(2006.79,2,1,51,0)=" ; comment out next 2 lines to stop copying orig. clin hist from file 70"
304^MAGD(2006.79,2,1,52,0)=" ;I $O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""H"",0)) S I=0 F J=0:1 S I=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""H"",I)) Q:I'>0 I $D(^(I,0)) S ^RARPT(RARPT,""H"",(J+1),0)=^(0)"
305^MAGD(2006.79,2,1,53,0)=" ;S:J ^RARPT(RARPT,""H"",0)=""^^""_J_""^""_J_""^""_DT"
306^MAGD(2006.79,2,1,54,0)=" ;Update Activity Log with 'images collected' transaction"
307^MAGD(2006.79,2,1,55,0)=" S DA=RARPT,DIE=""^RARPT("",DR=""100///""""NOW"""""",DR(2,74.01)=""2////""_$S($D(RAESIG):""V"",1:""C"")_"";3////""_DUZ D ^DIE K DA,DR,DE,DQ,DIE"
308^MAGD(2006.79,2,1,56,0)=" S DA=RARPT,DIK=""^RARPT("",RAQUEUED=1 D IX1^DIK ;D:$D(RAMDV) UPSTAT^RAUTL0"
309^MAGD(2006.79,2,1,57,0)=" N RARPTN S RARPTN=$P(^RARPT(RARPT,0),""^"")"
310^MAGD(2006.79,2,1,58,0)=" ;"
311^MAGD(2006.79,2,1,59,0)=" ; create a var RARIC to suppress display of info msg from ptr^rarte2"
312^MAGD(2006.79,2,1,60,0)=" ; if another case of this printset got cancelled"
313^MAGD(2006.79,2,1,61,0)=" I RAPRTSET N RARIC S RARIC=1 D PTR^RARTE2"
314^MAGD(2006.79,2,1,62,0)=" ; don't have to check raxit, since we're quitting now"
315^MAGD(2006.79,2,1,63,0)=" ;"
316^MAGD(2006.79,2,1,64,0)=" K DA,DIK,J,RAQUEUED"
317^MAGD(2006.79,2,1,65,0)="OUT L -^RARPT(RARPT)"
318^MAGD(2006.79,2,1,66,0)=" Q"
319^MAGD(2006.79,2,1,67,0)="PTR ; create pointer in file 74 for Imaging package"
320^MAGD(2006.79,2,1,68,0)=" ; called from MAGKEXC, MAGKEXC1 & MAGRIC"
321^MAGD(2006.79,2,1,69,0)=" ; input: RARPT - IEN of Rad/NM Report file #74"
322^MAGD(2006.79,2,1,70,0)=" ; MAGGP - IEN of record in file 2005 pointed to by a report"
323^MAGD(2006.79,2,1,71,0)=" ; returns: Y=0 - variable MAGGP does not exist"
324^MAGD(2006.79,2,1,72,0)=" ; Y=-1 - FileMan could not create an entry"
325^MAGD(2006.79,2,1,73,0)=" ; Y>0 - FileMan created an entry"
326^MAGD(2006.79,2,1,74,0)=" ;"
327^MAGD(2006.79,2,1,75,0)=" N DA,DIC"
328^MAGD(2006.79,2,1,76,0)=" I '$D(MAGGP) S Y=0 Q"
329^MAGD(2006.79,2,1,77,0)=" S DIC(""P"")=$P(^DD(74,2005,0),U,2)"
330^MAGD(2006.79,2,1,78,0)=" S DA(1)=RARPT,DIC=""^RARPT(""_DA(1)_"",2005,"",DIC(0)=""LZ"",X=MAGGP"
331^MAGD(2006.79,2,1,79,0)=" K DD,DO D FILE^DICN"
332^MAGD(2006.79,2,1,80,0)=" Q"
333^MAGD(2006.79,3,0)="RARTE2^3050311.125836"
334^MAGD(2006.79,3,1,0)="^2006.791^126^126"
335^MAGD(2006.79,3,1,1,0)="RARTE2 ;HISC/SWM-Edit/Delete a Report ;7/16/01 14:05"
336^MAGD(2006.79,3,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;**10,31**;Mar 16, 1998"
337^MAGD(2006.79,3,1,3,0)=" ; known vars-->RADFN,RACNI,RADTI,RARPT,RARPTN"
338^MAGD(2006.79,3,1,4,0)="PTR ; if current ^RADPT() rec is a PRINT SET,"
339^MAGD(2006.79,3,1,5,0)=" ; then for other ^RADPT() recs of the same PRINT SET,"
340^MAGD(2006.79,3,1,6,0)=" ; create its corresponding subrec in ^RARPT()"
341^MAGD(2006.79,3,1,7,0)=" S RAXIT=0"
342^MAGD(2006.79,3,1,8,0)=" I '$D(RADFN)!'$D(RACNI)!'$D(RADTI)!'$D(RARPT)!'$D(RARPTN) D Q"
343^MAGD(2006.79,3,1,9,0)=" . S RAXIT=1 Q:$G(RARIC)"
344^MAGD(2006.79,3,1,10,0)=" . I '$D(RAQUIET) W !!,$C(7),""Missing data (routine RARTE2)"",! S RAOUT=$$EOS^RAUTL5() Q"
345^MAGD(2006.79,3,1,11,0)=" . S RAERR=""Missing data needed by routine RARTE2"""
346^MAGD(2006.79,3,1,12,0)=" . Q"
347^MAGD(2006.79,3,1,13,0)=" N RA1,RA2,RA3,RAFDA,RAIEN,RAMSG ;RA3=exam status"
348^MAGD(2006.79,3,1,14,0)=" S RA1=0"
349^MAGD(2006.79,3,1,15,0)="PTR2 S RA1=$O(^RADPT(RADFN,""DT"",RADTI,""P"",""B"",RA1)) Q:RA1="""" S RA2=$O(^(RA1,0)),RA3=$P(^RADPT(RADFN,""DT"",RADTI,""P"",RA2,0),""^"",3) G:$P(^(0),""^"",25)'=2 PTR2 ;skip non-combined rpt"
350^MAGD(2006.79,3,1,16,0)=" G:RA2=RACNI PTR2 ;skip already processed case"
351^MAGD(2006.79,3,1,17,0)=" K RAFDA,RAIEN,RAMSG"
352^MAGD(2006.79,3,1,18,0)="ASK G:$G(RARIC) UPD G:$D(RAQUIET) UPD ; don't ask, if from Img pkg or Kurzweil"
353^MAGD(2006.79,3,1,19,0)=" I $P(^RA(72,+RA3,0),""^"",3)=0 D G:%=2 PTR2 G:%'=1 ASK"
354^MAGD(2006.79,3,1,20,0)=" . W !!,""Case "",RA1,"" of this print set has been cancelled."""
355^MAGD(2006.79,3,1,21,0)=" . W !,""Do you want to include it in the report anyway"""
356^MAGD(2006.79,3,1,22,0)=" . S %=2 D YN^DICN"
357^MAGD(2006.79,3,1,23,0)=" . W:%>0 ""..."",$S(%=2:""Ex"",%=1:""In"",1:""""),""clude case "",RA1"
358^MAGD(2006.79,3,1,24,0)=" . Q"
359^MAGD(2006.79,3,1,25,0)=" ; update file #70, field REPORT TEXT"
360^MAGD(2006.79,3,1,26,0)="UPD S $P(^RADPT(RADFN,""DT"",RADTI,""P"",RA2,0),U,17)=RARPT"
361^MAGD(2006.79,3,1,27,0)=" D INSERT"
362^MAGD(2006.79,3,1,28,0)=" Q:RAXIT G PTR2"
363^MAGD(2006.79,3,1,29,0)="INSERT ; add subrec to file #74's subfile #74.05"
364^MAGD(2006.79,3,1,30,0)=" S RAFDA(74.05,""?+2,""_RARPT_"","",.01)=$P(RARPTN,""-"")_""-""_RA1"
365^MAGD(2006.79,3,1,31,0)=" D UPDATE^DIE("""",""RAFDA"",""RAIEN"",""RAMSG"")"
366^MAGD(2006.79,3,1,32,0)=" I $D(RAMSG) D Q"
367^MAGD(2006.79,3,1,33,0)=" . S RAXIT=1 Q:$G(RARIC)"
368^MAGD(2006.79,3,1,34,0)=" . I '$D(RAQUIET) W !!,$C(7),""Error encountered while setting sub-records (routine RARTE2)"",! S RAOUT=$$EOS^RAUTL5() Q ;error detected"
369^MAGD(2006.79,3,1,35,0)=" . S RAERR=""Error encountered while setting sub-recs from RARTE2"""
370^MAGD(2006.79,3,1,36,0)=" Q"
371^MAGD(2006.79,3,1,37,0)="DEL17(RAIEN) ;del other print set members' pointer to #74"
372^MAGD(2006.79,3,1,38,0)=" Q:'$D(RADFN)!('$D(RADTI))"
373^MAGD(2006.79,3,1,39,0)=" N RA4,RA1 D EN3^RAUTL20(.RA4)"
374^MAGD(2006.79,3,1,40,0)=" Q:'$O(RA4(0))"
375^MAGD(2006.79,3,1,41,0)=" S RA1="""""
376^MAGD(2006.79,3,1,42,0)="D18 S RA1=$O(RA4(RA1)) Q:RA1="""""
377^MAGD(2006.79,3,1,43,0)=" ; kill xrefs, if any, for file #70's REPORT TEXT"
378^MAGD(2006.79,3,1,44,0)=" S DA(2)=RADFN,DA(1)=RADTI,DA=RA1"
379^MAGD(2006.79,3,1,45,0)=" ; if this exam's piece 17 doesn't match RAIEN, then don't remove pc17"
380^MAGD(2006.79,3,1,46,0)=" I $P($G(^RADPT(RADFN,""DT"",RADTI,""P"",RA1,0)),""^"",17)'=RAIEN G D18"
381^MAGD(2006.79,3,1,47,0)=" D ENKILL^RAXREF(70.03,17,RAIEN,.DA)"
382^MAGD(2006.79,3,1,48,0)=" ; set REPORT TEXT to null"
383^MAGD(2006.79,3,1,49,0)=" S:$D(^RADPT(RADFN,""DT"",RADTI,""P"",RA1,0)) $P(^(0),""^"",17)="""""
384^MAGD(2006.79,3,1,50,0)=" G D18"
385^MAGD(2006.79,3,1,51,0)="COPY ;copy physicians and diagnoses"
386^MAGD(2006.79,3,1,52,0)=" Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))!('$D(RAMEMARR))!('$D(RADRS))"
387^MAGD(2006.79,3,1,53,0)=" W !!,""... now copying "",$S(RADRS=1:""Diagnostic Codes"",1:""Staff & Resident data""),"" to other cases in this print set ..."",!"
388^MAGD(2006.79,3,1,54,0)=" N RA1,RA2,RA3"
389^MAGD(2006.79,3,1,55,0)=" N RA1PR,RA1PS ;prim res/staff"
390^MAGD(2006.79,3,1,56,0)=" N RA1SR,RA1SS ; sec res/staff arrays--(ien subfile #70.11)=ien file #200"
391^MAGD(2006.79,3,1,57,0)=" N RA1PD,RA1SD ; prim diag, then sec diags array"
392^MAGD(2006.79,3,1,58,0)=" N RAFDA,RAIEN,RAMSG"
393^MAGD(2006.79,3,1,59,0)=" ;prim res, prim staff, prim diag"
394^MAGD(2006.79,3,1,60,0)=" S RA1=^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0) S:RADRS=2 RA1PR=$P(RA1,""^"",12),RA1PS=$P(RA1,""^"",15) S:RADRS=1 RA1PD=$P(RA1,""^"",13)"
395^MAGD(2006.79,3,1,61,0)=" ;sec residents"
396^MAGD(2006.79,3,1,62,0)=" I RADRS=2,$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""SRR"",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""SRR"",RA1)) Q:+RA1'=RA1 S RA1SR(RA1)=+^(RA1,0)"
397^MAGD(2006.79,3,1,63,0)=" ;sec staff"
398^MAGD(2006.79,3,1,64,0)=" I RADRS=2,$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""SSR"",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""SSR"",RA1)) Q:+RA1'=RA1 S RA1SS(RA1)=+^(RA1,0)"
399^MAGD(2006.79,3,1,65,0)=" ;sec diagnoses"
400^MAGD(2006.79,3,1,66,0)=" I RADRS=1,$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""DX"",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""DX"",RA1)) Q:+RA1'=RA1 S RA1SD(RA1)=+^(RA1,0)"
401^MAGD(2006.79,3,1,67,0)=" ;loop thru other cases of this printset"
402^MAGD(2006.79,3,1,68,0)=" S RA1=0"
403^MAGD(2006.79,3,1,69,0)="COPYLOOP S RA1=$O(RAMEMARR(RA1)) G:RA1="""" COPYREF G:RA1=RACNI COPYLOOP ;skip what's done already"
404^MAGD(2006.79,3,1,70,0)=" ;"
405^MAGD(2006.79,3,1,71,0)=" ; copy primary staff and resident via Fileman"
406^MAGD(2006.79,3,1,72,0)=" I RADRS=2 D"
407^MAGD(2006.79,3,1,73,0)=" . S DA(2)=RADFN,DA(1)=RADTI,DA=RA1"
408^MAGD(2006.79,3,1,74,0)=" . S DIE=""^RADPT(""_DA(2)_"",""""DT"""",""_DA(1)_"",""""P"""","""
409^MAGD(2006.79,3,1,75,0)=" . S DR=""12////""_RA1PR_"";15////""_RA1PS"
410^MAGD(2006.79,3,1,76,0)=" . D ^DIE K DA,DIE,DR ; no locking"
411^MAGD(2006.79,3,1,77,0)=" . Q"
412^MAGD(2006.79,3,1,78,0)=" ;"
413^MAGD(2006.79,3,1,79,0)=" ; copy primary diagnostic code via Fileman"
414^MAGD(2006.79,3,1,80,0)=" I RADRS=1 D"
415^MAGD(2006.79,3,1,81,0)=" . S DA(2)=RADFN,DA(1)=RADTI,DA=RA1"
416^MAGD(2006.79,3,1,82,0)=" . S DIE=""^RADPT(""_DA(2)_"",""""DT"""",""_DA(1)_"",""""P"""","""
417^MAGD(2006.79,3,1,83,0)=" . S DR=""13////""_RA1PD"
418^MAGD(2006.79,3,1,84,0)=" . D ^DIE K DA,DIE,DR ; no locking"
419^MAGD(2006.79,3,1,85,0)=" . Q"
420^MAGD(2006.79,3,1,86,0)=" ;"
421^MAGD(2006.79,3,1,87,0)=" S RA2=RA1_"",""_RADTI_"",""_RADFN ;stem for dataserver call"
422^MAGD(2006.79,3,1,88,0)=" S DA(3)=RADFN,DA(2)=RADTI,DA(1)=RA1 ;base vars for DIK call"
423^MAGD(2006.79,3,1,89,0)=" I RADRS=2 S RA3=0 D KIL3 G:RAXIT Q ; sec res"
424^MAGD(2006.79,3,1,90,0)=" I RADRS=2 S RA3=0 D KIL4 G:RAXIT Q ; sec staff"
425^MAGD(2006.79,3,1,91,0)=" I RADRS=1 S RA3=0 D KIL5 G:RAXIT Q ; sec diag"
426^MAGD(2006.79,3,1,92,0)=" G COPYLOOP"
427^MAGD(2006.79,3,1,93,0)="KIL3 S RA3=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RA1,""SRR"",RA3)) G:RA3="""" COPY3"
428^MAGD(2006.79,3,1,94,0)=" S DA=RA3"
429^MAGD(2006.79,3,1,95,0)=" S DIK=""^RADPT(""_DA(3)_"",""""DT"""",""_DA(2)_"",""""P"""",""_DA(1)_"",""""SRR"""","""
430^MAGD(2006.79,3,1,96,0)=" D ^DIK"
431^MAGD(2006.79,3,1,97,0)=" G KIL3"
432^MAGD(2006.79,3,1,98,0)="COPY3 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SR(RA3)) Q:'RA3 Q:RAXIT"
433^MAGD(2006.79,3,1,99,0)="UP3 ;"
434^MAGD(2006.79,3,1,100,0)=" S RAFDA(70.09,""?+2,""_RA2_"","",.01)=RA1SR(RA3)"
435^MAGD(2006.79,3,1,101,0)=" D UPDATE^DIE("""",""RAFDA"",""RAIEN"",""RAMSG"") G:'$D(RAMSG) COPY3"
436^MAGD(2006.79,3,1,102,0)=" S RAXIT=1 W !!,$C(7),""Error encountered while in adding rec "",RA3,"" to sub-file 70.09"" Q"
437^MAGD(2006.79,3,1,103,0)="KIL4 S RA3=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RA1,""SSR"",RA3)) G:RA3="""" COPY4"
438^MAGD(2006.79,3,1,104,0)=" S DA=RA3"
439^MAGD(2006.79,3,1,105,0)=" S DIK=""^RADPT(""_DA(3)_"",""""DT"""",""_DA(2)_"",""""P"""",""_DA(1)_"",""""SSR"""","""
440^MAGD(2006.79,3,1,106,0)=" D ^DIK"
441^MAGD(2006.79,3,1,107,0)=" G KIL4"
442^MAGD(2006.79,3,1,108,0)="COPY4 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SS(RA3)) Q:'RA3 Q:RAXIT"
443^MAGD(2006.79,3,1,109,0)="UP4 ;"
444^MAGD(2006.79,3,1,110,0)=" S RAFDA(70.11,""?+2,""_RA2_"","",.01)=RA1SS(RA3)"
445^MAGD(2006.79,3,1,111,0)=" D UPDATE^DIE("""",""RAFDA"",""RAIEN"",""RAMSG"") G:'$D(RAMSG) COPY4"
446^MAGD(2006.79,3,1,112,0)=" S RAXIT=1 W !!,$C(7),""Error encountered while in adding rec "",RA3,"" to sub-file 70.11"" Q"
447^MAGD(2006.79,3,1,113,0)="KIL5 S RA3=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RA1,""DX"",RA3)) G:RA3="""" COPY5"
448^MAGD(2006.79,3,1,114,0)=" S DA=RA3"
449^MAGD(2006.79,3,1,115,0)=" S DIK=""^RADPT(""_DA(3)_"",""""DT"""",""_DA(2)_"",""""P"""",""_DA(1)_"",""""DX"""","""
450^MAGD(2006.79,3,1,116,0)=" D ^DIK"
451^MAGD(2006.79,3,1,117,0)=" G KIL5"
452^MAGD(2006.79,3,1,118,0)="COPY5 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SD(RA3)) Q:'RA3 Q:RAXIT"
453^MAGD(2006.79,3,1,119,0)="UP5 ;"
454^MAGD(2006.79,3,1,120,0)=" S RAFDA(70.14,""?+2,""_RA2_"","",.01)=RA1SD(RA3)"
455^MAGD(2006.79,3,1,121,0)=" D UPDATE^DIE("""",""RAFDA"",""RAIEN"",""RAMSG"") G:'$D(RAMSG) COPY5"
456^MAGD(2006.79,3,1,122,0)=" S RAXIT=1 W !!,$C(7),""Error encountered while in adding rec "",RA3,"" to sub-file 70.14"" Q"
457^MAGD(2006.79,3,1,123,0)="COPYREF ; clear out Fileman vars and quit"
458^MAGD(2006.79,3,1,124,0)=" K DA,DIK"
459^MAGD(2006.79,3,1,125,0)=" Q ; don't need to re-xref again"
460^MAGD(2006.79,3,1,126,0)="Q K DA Q"
461^MAGD(2006.79,4,0)="RAUTL^3050311.125836"
462^MAGD(2006.79,4,1,0)="^2006.791^101^101"
463^MAGD(2006.79,4,1,1,0)="RAUTL ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;12/4/97 14:21"
464^MAGD(2006.79,4,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998"
465^MAGD(2006.79,4,1,3,0)=" ;"
466^MAGD(2006.79,4,1,4,0)=" ;Date range selection. Time is allowed if RASKTIME is defined"
467^MAGD(2006.79,4,1,5,0)=" ;Past date assumed. BEGDATE and ENDDATE are output variables"
468^MAGD(2006.79,4,1,6,0)="DATE S RAPOP=0 K BEGDATE,ENDDATE W !!,""**** Date Range Selection ****"""
469^MAGD(2006.79,4,1,7,0)=" W ! S %DT=""APEX""_$S($D(RASKTIME):""T"",1:""""),%DT(""A"")="" Beginning DATE : "",%DT(0)=$S($D(RADDT):""0000101"",1:""-NOW"") D ^%DT S:Y<0 RAPOP=1 Q:Y<0 S (%DT(0),BEGDATE)=Y"
470^MAGD(2006.79,4,1,8,0)="END W ! S %DT=""APEX""_$S($D(RASKTIME):""T"",1:""""),%DT(""A"")="" Ending DATE : "" D ^%DT K %DT S:Y<0 RAPOP=1 Q:Y<0 S ENDDATE=Y"
471^MAGD(2006.79,4,1,9,0)=" Q"
472^MAGD(2006.79,4,1,10,0)="DATE1 S RAPOP=0 K BEGDATE,ENDDATE W !!,""**** Date Range Selection ****"""
473^MAGD(2006.79,4,1,11,0)=" W ! S %DT=""AEX""_$S($D(RASKTIME):""T"",1:""""),%DT(""A"")="" Beginning DATE : "",%DT(0)=$S($D(RADDT):""0000101"",1:""-NOW"") D ^%DT S:Y<0 RAPOP=1 Q:Y<0 S (%DT(0),BEGDATE)=Y"
474^MAGD(2006.79,4,1,12,0)="END1 W ! S %DT=""AEX""_$S($D(RASKTIME):""T"",1:""""),%DT(""A"")="" Ending DATE : "" D ^%DT K %DT S:Y<0 RAPOP=1 Q:Y<0 S ENDDATE=Y"
475^MAGD(2006.79,4,1,13,0)=" Q"
476^MAGD(2006.79,4,1,14,0)=" ;"
477^MAGD(2006.79,4,1,15,0)=" ;Generic device/queuing selector"
478^MAGD(2006.79,4,1,16,0)=" ;RAPOP will be >0 if the job was queued, or if device selection failed"
479^MAGD(2006.79,4,1,17,0)=" ; $D(RADUPSCN)&$D(RADFLTP) stems from the 'Duplicate Flash Card' option."
480^MAGD(2006.79,4,1,18,0)="ZIS I '$D(ZTDESC) S ZTDESC=""Rad/Nuc Med ""_$S($D(ZTRTN):ZTRTN,1:""UNKNOWN OPTION"")"
481^MAGD(2006.79,4,1,19,0)=" S RAMES=$S($D(RAMES):RAMES,1:""W !?5,*7,""""Request Queued."""""")"
482^MAGD(2006.79,4,1,20,0)=" W ! I $D(RASELDEV) W RASELDEV,! K RASELDEV"
483^MAGD(2006.79,4,1,21,0)=" S %ZIS=""QMP"" K:$G(IOP)=""Q"" %ZIS S:$D(RADUPSCN)&$D(RADFLTP) %ZIS(""B"")=RADFLTP D ^%ZIS S RAPOP=POP Q:RAPOP I $D(RAZIS),$E(IOST)'=""P"" D ^%ZISC S IOP=""Q"" W *7,!?5,""You must select a printer for this output."",! G ZIS"
484^MAGD(2006.79,4,1,22,0)=" G ZIS1:'$D(IO(""Q""))"
485^MAGD(2006.79,4,1,23,0)=" K IO(""Q"") S ZTIO=$S($D(ION):ION,1:"""") I ZTIO]"""" S ZTIO=ZTIO_$S($D(IO(""DOC"")):"";""_IOST_"";""_IO(""DOC""),1:"";""_IOST_"";""_IOM_"";""_IOSL)"
486^MAGD(2006.79,4,1,24,0)=" D ^%ZTLOAD"
487^MAGD(2006.79,4,1,25,0)=" I +$G(ZTSK(""D""))>0 X:$D(ZTSK) RAMES W:$D(ZTSK) "" Task #: ""_$G(ZTSK)"
488^MAGD(2006.79,4,1,26,0)=" K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH D HOME^%ZIS S RAPOP=1 Q"
489^MAGD(2006.79,4,1,27,0)="ZIS1 K RAMES,RASELDEV,ZTDESC,ZTRTN,ZTSAVE Q"
490^MAGD(2006.79,4,1,28,0)=" ;"
491^MAGD(2006.79,4,1,29,0)="CLOSE I $D(ZTQUEUED) S ZTREQ=""@"" Q"
492^MAGD(2006.79,4,1,30,0)=" D ^%ZISC Q"
493^MAGD(2006.79,4,1,31,0)=" ;"
494^MAGD(2006.79,4,1,32,0)="D S Y=$P(""JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"",""^"",$E(Y,4,5))_"" ""_$S(Y#100:$J(Y#100\1,2)_"","",1:"""")_(Y\10000+1700)_$S(Y#1:"" ""_$E(Y_0,9,10)_"":""_$E(Y_""000"",11,12),1:"""") Q"
495^MAGD(2006.79,4,1,33,0)=" ;"
496^MAGD(2006.79,4,1,34,0)=" ;called to do some user checks"
497^MAGD(2006.79,4,1,35,0)=" ;if div param set to ask user instead of auto filing DUZ, prompt for"
498^MAGD(2006.79,4,1,36,0)=" ; access/verify code"
499^MAGD(2006.79,4,1,37,0)=" ;if RAKEY is defined, check if user owns this key and set RAPOP=1"
500^MAGD(2006.79,4,1,38,0)=" ; if user doesn't own key"
501^MAGD(2006.79,4,1,39,0)="USER S RADUZ=DUZ S:'$D(RAMDV) RAMDV="""" I '$P(RAMDV,""^"",6) S %=""A"",%DUZ=DUZ W ! D ^XUVERIFY G USERQ:%=-1 I %'=1 W *7,"" ??"" G USER"
502^MAGD(2006.79,4,1,40,0)="USER1 Q:'$D(RAKEY) Q:$D(^XUSEC(RAKEY,RADUZ)) W !!?3,*7,""Must be a user with the appropriate privileges to continue!"""
503^MAGD(2006.79,4,1,41,0)="USERQ S RAPOP=1 Q"
504^MAGD(2006.79,4,1,42,0)=" ;"
505^MAGD(2006.79,4,1,43,0)="DEV ;EXECUTEABLE HELP FOR DEVICE FIELDS IN FILE 79.1 (IMAGING LOCATIONS)"
506^MAGD(2006.79,4,1,44,0)=" D HOME^%ZIS W @IOF,!,""The following is a list of possible devices. You must choose"",!,""one of these by entering in the device's full name."",!!,""NOTE: This field is not a pointer field to file 3.5!"",!"
507^MAGD(2006.79,4,1,45,0)=" W !?3,""Device Name:"",?25,""Device Location:"",!?3,""------------"",?25,""----------------"""
508^MAGD(2006.79,4,1,46,0)=" F I=0:0 S I=$O(^%ZIS(1,I)) Q:I'>0 I $D(^(I,0)) W !?3,$P(^(0),""^""),?25,$S($D(^(1)):^(1),1:"""") I ($Y+4)>IOSL R !,""(Type """"^"""" to stop)"",X:DTIME Q:'$T!(X=""^"") W @IOF"
509^MAGD(2006.79,4,1,47,0)=" Q"
510^MAGD(2006.79,4,1,48,0)=" ;"
511^MAGD(2006.79,4,1,49,0)="VERIFY ;Ask Access Code"
512^MAGD(2006.79,4,1,50,0)=" K RADUZ S %=""A"",%DUZ=DUZ W ! D ^XUVERIFY S RADUZ=DUZ Q:%=-1!(%=1) W:%=2 *7,!,""Sorry, that's not your access code. Try again."" W:%=0 !,""Enter your access code or an uparrow to exit."" G VERIFY"
513^MAGD(2006.79,4,1,51,0)=" ;"
514^MAGD(2006.79,4,1,52,0)="A ;Create signature block name using RASIG(""PER"") as input IEN of file 200"
515^MAGD(2006.79,4,1,53,0)=" ;Write signature to node 20 of file 200"
516^MAGD(2006.79,4,1,54,0)=" ;(Signature is name in Firstname Lastname format)"
517^MAGD(2006.79,4,1,55,0)=" S %X=$P(^VA(200,RASIG(""PER""),0),""^""),%X=$P(%X,"","",2)_"" ""_$P(%X,"","")_$P(%X,"","",3),$P(^VA(200,RASIG(""PER""),20),""^"",2)=%X K %X Q"
518^MAGD(2006.79,4,1,56,0)=" ;"
519^MAGD(2006.79,4,1,57,0)="DUZ ;Lookup and set RASIG(""PER"")=New Person File IFN, set signature block"
520^MAGD(2006.79,4,1,58,0)=" ;text in File 200 if necessary, set RASIG(""NAME"")=signature block text"
521^MAGD(2006.79,4,1,59,0)=" S %=1 I $D(DUZ)#2,+DUZ>0,$D(^VA(200,DUZ,0)) S RASIG(""PER"")=DUZ"
522^MAGD(2006.79,4,1,60,0)=" I '$D(RASIG(""PER"")) S %=0 W:'$D(%INT) !,*7,""YOU ARE NOT IN THE 'NEW PERSON' FILE. CONTACT YOUR IRM SERVICE"",! K %INT Q"
523^MAGD(2006.79,4,1,61,0)=" I '$D(^VA(200,RASIG(""PER""),20)) D A K %INT Q"
524^MAGD(2006.79,4,1,62,0)=" I $P(^VA(200,RASIG(""PER""),20),""^"",2)="""" S %X=$P(^VA(200,RASIG(""PER""),0),""^""),%X=$P(%X,"","",2)_"" ""_$P(%X,"","")_$P(%X,"","",3),$P(^(20),""^"",2)=%X K %X"
525^MAGD(2006.79,4,1,63,0)=" S RASIG(""NAME"")=$P(^VA(200,RASIG(""PER""),20),""^"",2) K %INT Q"
526^MAGD(2006.79,4,1,64,0)=" ;"
527^MAGD(2006.79,4,1,65,0)="SSN(PID,BID,DOD) ;returns full Pt.ID (VA(""PID"")), BID=1 returns VA(""BID"")"
528^MAGD(2006.79,4,1,66,0)=" ;DOD is defined to internal entry # of eligibility of desired Pt.ID"
529^MAGD(2006.79,4,1,67,0)=" N DFN"
530^MAGD(2006.79,4,1,68,0)=" I '$D(RADFN) Q ""Unknown"""
531^MAGD(2006.79,4,1,69,0)=" S:'$D(BID) BID="""" S:$D(DOD) VAPTYP=DOD"
532^MAGD(2006.79,4,1,70,0)=" S DFN=RADFN D PID^VADPT6 I VAERR K VAERR Q ""Unknown"""
533^MAGD(2006.79,4,1,71,0)=" S RASSN=$S(BID:VA(""BID""),1:VA(""PID""))"
534^MAGD(2006.79,4,1,72,0)=" K VA(""BID""),VA(""PID""),VAERR,VAPTYP"
535^MAGD(2006.79,4,1,73,0)=" Q RASSN"
536^MAGD(2006.79,4,1,74,0)="WARNPRC ; send warning if user changes procedure within exam edit"
537^MAGD(2006.79,4,1,75,0)=" ; and the exam has either or both radiopharms and meds"
538^MAGD(2006.79,4,1,76,0)=" ; RAY (sub-rec 70.03) comes from rtns RAEDCN or RAEDPT (exam edit)"
539^MAGD(2006.79,4,1,77,0)=" ; RAPRIT (ien file 71) comes from rtn RASTED (status tracking)"
540^MAGD(2006.79,4,1,78,0)=" Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))"
541^MAGD(2006.79,4,1,79,0)=" Q:$G(RAY)']""""&('$D(RAPRIT))"
542^MAGD(2006.79,4,1,80,0)=" N RAMEDS,RADIO,RATAB,RATEXT"
543^MAGD(2006.79,4,1,81,0)=" S RAMEDS=0,RADIO=0"
544^MAGD(2006.79,4,1,82,0)=" I $G(RAY)]"""",$P(RAY,U,2)=RAPRI Q ;no change in procedure"
545^MAGD(2006.79,4,1,83,0)=" I $G(RAPRIT)]"""",RAPRIT=RAPRI Q ;no change in procedure"
546^MAGD(2006.79,4,1,84,0)=" S RADIO=$P($G(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0)),U,28) ;ptr fle #70.2"
547^MAGD(2006.79,4,1,85,0)=" S RADIO=+$O(^RADPTN(+RADIO,""NUC"",0))"
548^MAGD(2006.79,4,1,86,0)=" S RAMEDS=+$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""RX"",0))"
549^MAGD(2006.79,4,1,87,0)=" S RAWHICH=0 ;first assume neither radiopharm nor meds"
550^MAGD(2006.79,4,1,88,0)=" I 'RAMEDS,RADIO S RAWHICH=1 ;radiopharm only"
551^MAGD(2006.79,4,1,89,0)=" I RAMEDS,'RADIO S RAWHICH=2 ;meds only"
552^MAGD(2006.79,4,1,90,0)=" I RAMEDS,RADIO S RAWHICH=3 ;both radiopharm and meds"
553^MAGD(2006.79,4,1,91,0)=" G:'RAWHICH WARN0"
554^MAGD(2006.79,4,1,92,0)=" W !!?2,""**"",?21,""Since you have changed the procedure,"",?76,""**"""
555^MAGD(2006.79,4,1,93,0)=" S RATAB=$S(RAWHICH=1:26,RAWHICH=2:34,1:21)"
556^MAGD(2006.79,4,1,94,0)=" W !?2,""**"",?RATAB,""the"",$S(RAWHICH#2:"" Radiopharmaceuticals"",1:""""),$S(RAWHICH=3:"" and"",1:""""),$S(RAWHICH>1:"" Meds"",1:""""),"" for"",?76,""**"""
557^MAGD(2006.79,4,1,95,0)=" S RATEXT=$S($G(RAY)]"""":$P($G(^RAMIS(71,+$P(RAY,U,2),0)),U),1:$P($G(^RAMIS(71,+$G(RAPRIT),0)),U)),RATAB=80-$L(RATEXT)/2"
558^MAGD(2006.79,4,1,96,0)=" W !?2,""**"",?RATAB,RATEXT,?76,""**"""
559^MAGD(2006.79,4,1,97,0)=" W !?2,""**"",?30,""will now be deleted."",?76,""**"",!,*7"
560^MAGD(2006.79,4,1,98,0)=" Q"
561^MAGD(2006.79,4,1,99,0)="WARN0 W !!?2,""**"",?17,""You have changed the procedure, but there are"",?76,""**"""
562^MAGD(2006.79,4,1,100,0)=" W !?2,""**"",?14,""no data for Radiopharmaceuticals and Meds to delete."",?76,""**"",*7,!"
563^MAGD(2006.79,4,1,101,0)=" Q"
564^MAGD(2006.79,5,0)="RAUTL1^3050311.125836"
565^MAGD(2006.79,5,1,0)="^2006.791^151^151"
566^MAGD(2006.79,5,1,1,0)="RAUTL1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;10/22/97 13:54"
567^MAGD(2006.79,5,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;**5,9,18**;Mar 16, 1998"
568^MAGD(2006.79,5,1,3,0)=" ;last midification by SS for P18 June 19,00"
569^MAGD(2006.79,5,1,4,0)=" I ""IOSCR""'[X!(X="""") S X=""Unknown"" Q"
570^MAGD(2006.79,5,1,5,0)=" G @($E(X))"
571^MAGD(2006.79,5,1,6,0)=" ;Set X=Inpatient Location"
572^MAGD(2006.79,5,1,7,0)="I S X=$S($D(^DIC(42,+$P(^RADPT(D0,""DT"",D1,""P"",D2,0),""^"",6),0)):$P(^(0),""^""),1:""Unknown"")"
573^MAGD(2006.79,5,1,8,0)=" Q"
574^MAGD(2006.79,5,1,9,0)=" ;"
575^MAGD(2006.79,5,1,10,0)=" ;Set X=Outpatient Location"
576^MAGD(2006.79,5,1,11,0)="O S X=$S($D(^SC(+$P(^RADPT(D0,""DT"",D1,""P"",D2,0),""^"",8),0)):$P(^(0),""^""),1:""Unknown"")"
577^MAGD(2006.79,5,1,12,0)=" Q"
578^MAGD(2006.79,5,1,13,0)=" ;"
579^MAGD(2006.79,5,1,14,0)=" ;Set X=Contract/Sharing Agreement patient location"
580^MAGD(2006.79,5,1,15,0)="S ;"
581^MAGD(2006.79,5,1,16,0)="C S X=$S($D(^DIC(34,+$P(^RADPT(D0,""DT"",D1,""P"",D2,0),""^"",9),0)):$P(^(0),""^""),1:""Unknown"")"
582^MAGD(2006.79,5,1,17,0)=" Q"
583^MAGD(2006.79,5,1,18,0)=" ;"
584^MAGD(2006.79,5,1,19,0)=" ;Set X=Research patient location"
585^MAGD(2006.79,5,1,20,0)="R S X=$S($D(^RADPT(D0,""DT"",D1,""P"",D2,""R"")):$P(^(""R""),""^""),1:""Unknown"") Q"
586^MAGD(2006.79,5,1,21,0)=" ;"
587^MAGD(2006.79,5,1,22,0)=" ;Set X=time of day in external format (ex: 2:28 PM)"
588^MAGD(2006.79,5,1,23,0)="NOW S %=$P($H,"","",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) D TIME"
589^MAGD(2006.79,5,1,24,0)=" Q"
590^MAGD(2006.79,5,1,25,0)=" ;Input X=FM date/time, Output X=time (external format)"
591^MAGD(2006.79,5,1,26,0)="TIME S X=$E($P(X,""."",2)_""0000"",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_"":""_$E(X#100+100,2,3)_"" ""_$E(""AP"",%+1)_""M"" S:$P(X,"":"")=0 X=12_"":""_$P(X,"":"",2)"
592^MAGD(2006.79,5,1,27,0)=" Q"
593^MAGD(2006.79,5,1,28,0)=" ;"
594^MAGD(2006.79,5,1,29,0)="ELAPSED ;Pass parameters X (from date) and X1 (to date)"
595^MAGD(2006.79,5,1,30,0)=" ;Variable Y is returned as either an elapsed time in the form DD:HH:MM where DD=days, HH=hours, MM=minutes or as the string 'Neg. Time' indicating a negative elapsed time"
596^MAGD(2006.79,5,1,31,0)=" ;Variable Y1 is returned as the # of minutes of elapsed time"
597^MAGD(2006.79,5,1,32,0)=" I '$D(RAMTIME) S DIC=""^DD(""""FUNC"""","",DIC(0)=""FX"",RAX=X,X=""MINUTES"" D ^DIC K DIC S X=RAX S:$D(^DD(""FUNC"",+Y,1)) RAMTIME=^(1) I '$D(RAMTIME) W *7,!!,""Can't continue --- No 'MINUTES' function found in File Manager"" K Y,Y1 G Q"
598^MAGD(2006.79,5,1,33,0)=" X RAMTIME S Y1=X I X<0 S Y=""Neg. Time"" G Q"
599^MAGD(2006.79,5,1,34,0)="MINUTS S X(1)=X\1440,X=X-(1440*X(1)),X(2)=X\60,X(3)=X-(60*X(2)),Y=$E(100+X(1),2,3)_"":""_$E(100+X(2),2,3)_"":""_$E(100+X(3),2,3)"
600^MAGD(2006.79,5,1,35,0)="Q K RAX,X Q"
601^MAGD(2006.79,5,1,36,0)=" ;"
602^MAGD(2006.79,5,1,37,0)="UPDATE ;Entry point for Update Rad/Nuc Med Exam Status option"
603^MAGD(2006.79,5,1,38,0)=" I $O(RACCESS(DUZ,""""))="""" D SETVARS^RAPSET1(0)"
604^MAGD(2006.79,5,1,39,0)=" I $G(RAIMGTY)="""" D SETVARS^RAPSET1(1)"
605^MAGD(2006.79,5,1,40,0)=" I $G(RAIMGTY)="""" K XQUIT Q ; didn't sign-on to an imaging location"
606^MAGD(2006.79,5,1,41,0)=" D ^RACNLU G UPQ:""^""[X"
607^MAGD(2006.79,5,1,42,0)=" I $D(^RA(72,""AA"",RAIMGTY,9,+RAST)),'$D(^XUSEC(""RA MGR"",DUZ)) W !!?3,*7,""You do not have the appropriate access privileges to act on completed exams."" G UPDATE"
608^MAGD(2006.79,5,1,43,0)=" I $D(^RA(72,""AA"",RAIMGTY,0,+RAST)) W !!?3,*7,""Exam has been 'cancelled' therefore the status cannot be changed."" G UPDATE"
609^MAGD(2006.79,5,1,44,0)=" ;D UP1 I RAOR>0 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE=""^RADPT(""_DA(2)_"",""""DT"""",""_DA(1)_"",""""P"""","",DR=""100///""""NOW"""""",DR(2,70.07)=""2///U;3////""_$S($G(RADUZ):RADUZ,1:DUZ) D ^DIE"
610^MAGD(2006.79,5,1,45,0)=" D UP1 I RAOR>0 D"
611^MAGD(2006.79,5,1,46,0)=" .L +^RADPT(RADFN,""DT"",RADTI,""P"",RACNI)"
612^MAGD(2006.79,5,1,47,0)=" .N RAIEN"
613^MAGD(2006.79,5,1,48,0)=" .S RAIENS=""+1,""_RACNI_"",""_RADTI_"",""_RADFN_"","""
614^MAGD(2006.79,5,1,49,0)=" .S RAFDA(70.07,RAIENS,.01)=""NOW"""
615^MAGD(2006.79,5,1,50,0)=" .K RAERR D UPDATE^DIE(""E"",""RAFDA"",""RAIEN"",""RAERR"")"
616^MAGD(2006.79,5,1,51,0)=" .K RAFDA,RAIENS"
617^MAGD(2006.79,5,1,52,0)=" .I $D(RAERR) L -^RADPT(RADFN,""DT"",RADTI,""P"",RACNI) K RAIEN Q"
618^MAGD(2006.79,5,1,53,0)=" .S RAIENS=RAIEN(1)_"",""_RACNI_"",""_RADTI_"",""_RADFN_"","""
619^MAGD(2006.79,5,1,54,0)=" .S RAFDA(70.07,RAIENS,2)=""U"""
620^MAGD(2006.79,5,1,55,0)=" .S RAFDA(70.07,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ)"
621^MAGD(2006.79,5,1,56,0)=" .D FILE^DIE(,""RAFDA"")"
622^MAGD(2006.79,5,1,57,0)=" .L -^RADPT(RADFN,""DT"",RADTI,""P"",RACNI)"
623^MAGD(2006.79,5,1,58,0)="UPQ K RAFDA,RAIENS"
624^MAGD(2006.79,5,1,59,0)=" K %,D,DA,DE,DIC,DIE,DQ,DR,I,J,POP,RACS,RAEND,RAF5,RAFL,RAFST,RAI,RAIX,RAJ1,RAORDIFN,RAPRIT,RAHEAD,RASN,RAOR,RASTI,RASSN,RADATE,RAST,RACN,RACNI,RADFN,RADTE,RADTI,RANME,RAPRC,RARPT,X,Y,Z,^TMP($J,""RAEX""),C,DIPGM Q"
625^MAGD(2006.79,5,1,60,0)=" ;"
626^MAGD(2006.79,5,1,61,0)=" ;Exam status updating and accompanying updates to status log, oe/rr"
627^MAGD(2006.79,5,1,62,0)="UP1 N RA8 S RA8=0 ;use this to flag when one alert has been sent"
628^MAGD(2006.79,5,1,63,0)=" D CMPAFTR^RAO7XX(1) ;P18 if procedure changed in RAEDCN or RAEDPT sends XX message to CPRS if needed"
629^MAGD(2006.79,5,1,64,0)=" ; RA EDITCN and RA EDITPT should process this case only"
630^MAGD(2006.79,5,1,65,0)=" I $D(RAOPT(""EDITCN""))!($D(RAOPT(""EDITPT""))) D UP2,UPK Q"
631^MAGD(2006.79,5,1,66,0)=" ; see if this case belongs to a printset"
632^MAGD(2006.79,5,1,67,0)=" N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR"
633^MAGD(2006.79,5,1,68,0)=" D EN2^RAUTL20(.RAMEMARR) ;043099 always recalculate RAPRTSET"
634^MAGD(2006.79,5,1,69,0)=" ; if not print set, then just process this case only"
635^MAGD(2006.79,5,1,70,0)=" I 'RAPRTSET D UP2,UPK Q"
636^MAGD(2006.79,5,1,71,0)=" ;case belongs to print set, so process all members of same print set"
637^MAGD(2006.79,5,1,72,0)=" N RACNISAV,RA7"
638^MAGD(2006.79,5,1,73,0)=" S RACNISAV=RACNI,RA7=0"
639^MAGD(2006.79,5,1,74,0)=" F S RA7=$O(RAMEMARR(RA7)) Q:RA7="""" S RACNI=RA7 D UP2"
640^MAGD(2006.79,5,1,75,0)=" S RACNI=RACNISAV"
641^MAGD(2006.79,5,1,76,0)=" G UPK"
642^MAGD(2006.79,5,1,77,0)="UP2 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE=""^RADPT(""_DA(2)_"",""""DT"""",""_DA(1)_"",""""P"""","""
643^MAGD(2006.79,5,1,78,0)=" N RAAFTER,RABEFORE"
644^MAGD(2006.79,5,1,79,0)=" D STUFF^RASTREQ1 I RAOR<0,$D(RASN) W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?5,""...exam status remains '"",RASN,""'."" K DIE,RACS,RAPRIT Q"
645^MAGD(2006.79,5,1,80,0)=" W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?3,""...will now designate exam status as '"",RASN,""'... for case no. "",$P($G(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0)),U)"
646^MAGD(2006.79,5,1,81,0)=" ; S DR=""3////""_RASTI_$S($P(RAMDV,""^"",10):"";75///^S X=$$MIDNGHT^RAUTL5($$NOW^XLFDT())"",1:"""")"
647^MAGD(2006.79,5,1,82,0)=" ; user duz could be in RADUZ, if session is from the Voice recognition"
648^MAGD(2006.79,5,1,83,0)=" ;S DR(2,70.05)=$S($P(RAMDV,""^"",11)&('$D(ZTQUEUED)):"".01;"",1:"""")_""2////""_RASTI_"";3////""_$S($G(RADUZ):RADUZ,1:DUZ)"
649^MAGD(2006.79,5,1,84,0)=" ;D ^DIE"
650^MAGD(2006.79,5,1,85,0)=" L +^RADPT(RADFN,""DT"",RADTI,""P"",RACNI)"
651^MAGD(2006.79,5,1,86,0)=" N RAIEN"
652^MAGD(2006.79,5,1,87,0)=" S RAIENS=RACNI_"",""_RADTI_"",""_RADFN_"","""
653^MAGD(2006.79,5,1,88,0)=" S RAFDA(70.03,RAIENS,3)=RASTI"
654^MAGD(2006.79,5,1,89,0)=" K RAERR D FILE^DIE(,""RAFDA"",""RAERR"")"
655^MAGD(2006.79,5,1,90,0)=" I $D(RAERR) L -^RADPT(RADFN,""DT"",RADTI,""P"",RACNI) G UP2K ;L - P18"
656^MAGD(2006.79,5,1,91,0)=" I $P(RAMDV,""^"",10) D"
657^MAGD(2006.79,5,1,92,0)=" .S RAIENS=""+1,""_RACNI_"",""_RADTI_"",""_RADFN_"","""
658^MAGD(2006.79,5,1,93,0)=" .S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT())"
659^MAGD(2006.79,5,1,94,0)=" .D UPDATE^DIE(,""RAFDA"",""RAIEN"")"
660^MAGD(2006.79,5,1,95,0)=" .K RAFDA,RAIENS"
661^MAGD(2006.79,5,1,96,0)=" .Q:'$D(RAIEN(1))"
662^MAGD(2006.79,5,1,97,0)=" .I $P(RAMDV,""^"",11),('$D(ZTQUEUED)) D"
663^MAGD(2006.79,5,1,98,0)=" ..S DIE=DIE_RACNI_"",""""T"""","",DA=RAIEN(1)"
664^MAGD(2006.79,5,1,99,0)=" ..S DR="".01"""
665^MAGD(2006.79,5,1,100,0)=" ..D ^DIE"
666^MAGD(2006.79,5,1,101,0)=" .S RAIENS=RAIEN(1)_"",""_RACNI_"",""_RADTI_"",""_RADFN_"","""
667^MAGD(2006.79,5,1,102,0)=" .S RAFDA(70.05,RAIENS,2)=RASTI"
668^MAGD(2006.79,5,1,103,0)=" .S RAFDA(70.05,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ)"
669^MAGD(2006.79,5,1,104,0)=" .K RAERR2 D FILE^DIE(,""RAFDA"")"
670^MAGD(2006.79,5,1,105,0)=" L -^RADPT(RADFN,""DT"",RADTI,""P"",RACNI)"
671^MAGD(2006.79,5,1,106,0)=" ;"
672^MAGD(2006.79,5,1,107,0)="UP2K K DE,DQ,DIE,DR,RAFDA,RAIENS K:$D(RAERR) RACS,RAPRIT Q:$D(RAERR) W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?10,""...exam status "",$S($G(RABEFORE)>$G(RAAFTER):""backed down"",1:""successfully updated""),""."" D ^RAORDC"
673^MAGD(2006.79,5,1,108,0)=" I RA8=0,$D(^RA(72,RASTI,""ALERT"")),$P(^(""ALERT""),""^"")=""y"" D:$$ORVR^RAORDU()=2.5 OERR D:$$ORVR^RAORDU()'<3 OERR3 S RA8=1"
674^MAGD(2006.79,5,1,109,0)=" I $D(^RA(72,RASTI,0)),$P(^(0),""^"",3)>1,RACS'=""Y"",$S('$D(RAF5):1,$P(^DIC(42,+RAF5,0),U,3)=""D"":1,1:0) D EN^RAUTL0"
675^MAGD(2006.79,5,1,110,0)=" I $P(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0),U,30)="""" D EXM^RAHLRPC"
676^MAGD(2006.79,5,1,111,0)=" K RACS,RAORDIFN,RAPRIT,RAF5"
677^MAGD(2006.79,5,1,112,0)=" Q"
678^MAGD(2006.79,5,1,113,0)="UPK K ORIFN,ORVP,ORNOTE,ORBPMSG,RACS,RAORDIFN,RAPRIT,RAF5"
679^MAGD(2006.79,5,1,114,0)=" Q"
680^MAGD(2006.79,5,1,115,0)="OERR ;Send Alert to OERR after pt examined"
681^MAGD(2006.79,5,1,116,0)=" S ORVP=RADFN_"";DPT("",ORBPMSG=""Rad Pt Examined - ""_$S($D(^RAMIS(71,RAPRIT,0)):$E($P(^(0),""^""),1,24),1:""Unknown"") S:$D(^RAO(75.1,+RAORDIFN,0)) ORIFN=+$P(^(0),""^"",7) S ORNOTE(21)=$S($D(ORIFN):1,1:"""") D NOTE^ORX3"
682^MAGD(2006.79,5,1,117,0)=" Q"
683^MAGD(2006.79,5,1,118,0)="OERR3 ; Send RADIOLOGY PATIENT EXAMINED notification via oe/rr v3"
684^MAGD(2006.79,5,1,119,0)=" ; Called from UP1"
685^MAGD(2006.79,5,1,120,0)=" ;"
686^MAGD(2006.79,5,1,121,0)=" ; RADFN,RADTI,RACNI,RAPRIT must be defined"
687^MAGD(2006.79,5,1,122,0)=" Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))!('$D(RAPRIT))"
688^MAGD(2006.79,5,1,123,0)=" ;"
689^MAGD(2006.79,5,1,124,0)=" N RAIENS,RAMSG,RAOIFN,RAOSTS,RAONODE,RADPTNDE,RAREQPHY"
690^MAGD(2006.79,5,1,125,0)=" S RADPTNDE=$G(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0))"
691^MAGD(2006.79,5,1,126,0)=" S RAOIFN=$P(RADPTNDE,U,11) Q:'RAOIFN ;file 75.1 ien"
692^MAGD(2006.79,5,1,127,0)=" S RAONODE=$G(^RAO(75.1,+RAOIFN,0))"
693^MAGD(2006.79,5,1,128,0)=" S RAOSTS=$P(RAONODE,U,5) Q:RAOSTS'=6 ;active exams only"
694^MAGD(2006.79,5,1,129,0)=" S RAOIFN=$P(RAONODE,U,7) ;file 100 ien"
695^MAGD(2006.79,5,1,130,0)=" S RAREQPHY=+$P(RADPTNDE,U,14) ;ordering provider"
696^MAGD(2006.79,5,1,131,0)=" S RAREQPHY(RAREQPHY)="""""
697^MAGD(2006.79,5,1,132,0)=" S RAMSG=""Imaging Pt Examined - ""_$S($D(^RAMIS(71,RAPRIT,0)):$E($P(^(0),U),1,24),1:""Unknown""),RAMSG=$E(RAMSG,1,51)"
698^MAGD(2006.79,5,1,133,0)=" S RAIENS=RADTI_""~""_RACNI"
699^MAGD(2006.79,5,1,134,0)=" ;"
700^MAGD(2006.79,5,1,135,0)=" ; oe parameters:"
701^MAGD(2006.79,5,1,136,0)=" ; ORN: notification id (#100.9 ien)"
702^MAGD(2006.79,5,1,137,0)=" ; | ORBDFN: patient id (#2 ien)"
703^MAGD(2006.79,5,1,138,0)=" ; | | ORNUM: order number (#100 ien)"
704^MAGD(2006.79,5,1,139,0)=" ; | | | ORBADUZ: recipient array"
705^MAGD(2006.79,5,1,140,0)=" ; | | | | ORBPMSG: message text"
706^MAGD(2006.79,5,1,141,0)=" ; | | | | | ORBPDATA exam dt~case iens"
707^MAGD(2006.79,5,1,142,0)=" ; | | | | | |"
708^MAGD(2006.79,5,1,143,0)=" D EN^ORB3(21,RADFN,RAOIFN,.RAREQPHY,RAMSG,RAIENS)"
709^MAGD(2006.79,5,1,144,0)=" Q"
710^MAGD(2006.79,5,1,145,0)=" ;"
711^MAGD(2006.79,5,1,146,0)=" ;Called by many report programs. Sets RACRT() array containing all"
712^MAGD(2006.79,5,1,147,0)=" ;exam statuses that are to be included on the report. RACRT is set"
713^MAGD(2006.79,5,1,148,0)=" ;to the piece of the Exam Status File #72 record that corresponds"
714^MAGD(2006.79,5,1,149,0)=" ;to the report being generated."
715^MAGD(2006.79,5,1,150,0)="CRIT F I=0:0 S I=$O(^RA(72,I)) Q:'I I $D(^(I,.3)),$P(^(.3),""^"",RACRT)=""y"" S RACRT(I)="""""
716^MAGD(2006.79,5,1,151,0)=" Q"
717^MAGD(2006.79,6,0)="RAUTL2^3050311.125836"
718^MAGD(2006.79,6,1,0)="^2006.791^142^142"
719^MAGD(2006.79,6,1,1,0)="RAUTL2 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;11/10/97 11:18"
720^MAGD(2006.79,6,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;**10,26,45**;Mar 16, 1998"
721^MAGD(2006.79,6,1,3,0)=" ;"
722^MAGD(2006.79,6,1,4,0)=" ;Called from many points within Rad/Nuc Med package ;ch"
723^MAGD(2006.79,6,1,5,0)=" ;INPUT VARIABLES: Y=IEN of Rad Report file #74"
724^MAGD(2006.79,6,1,6,0)=" ; XRT0,XRT1 If set, will do some response time checks"
725^MAGD(2006.79,6,1,7,0)=" ;OUTPUT VARIABLES:"
726^MAGD(2006.79,6,1,8,0)=" ; RADFN=Patient DFN, RADTE=Exam date/time (FM format), "
727^MAGD(2006.79,6,1,9,0)=" ; RACN=long case number, RADTI=reverse exam date/time,"
728^MAGD(2006.79,6,1,10,0)=" ; RACNI=short case number, RADATE=Exam date/time (external format)"
729^MAGD(2006.79,6,1,11,0)=" ; Y=If active case, zeroeth node of case record in file #70"
730^MAGD(2006.79,6,1,12,0)="RASET D:$D(XRTL) T0^%ZOSV S Y=$S($D(^RARPT(+Y,0)):^(0),1:"""") Q:'Y S RADFN=+$P(Y,""^"",2),RADTE=+$P(Y,""^"",3),RACN=+$P(Y,""^"",4),RADTI=9999999.9999-RADTE,RACNI=$O(^RADPT(""ADC"",$P(Y,""^""),RADFN,RADTI,0)) S Y=RADTE D D^RAUTL S RADATE=Y"
731^MAGD(2006.79,6,1,13,0)=" S Y="""" I RACNI,$D(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0)) S Y=^(0)"
732^MAGD(2006.79,6,1,14,0)=" I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV"
733^MAGD(2006.79,6,1,15,0)=" Q"
734^MAGD(2006.79,6,1,16,0)=" ;"
735^MAGD(2006.79,6,1,17,0)=" ;Called from 2 x-refs on file #74, Rpt Status fld 5 ;ch"
736^MAGD(2006.79,6,1,18,0)=" ;Does sets and kills for 'ARES', and 'ASTF' xrefs"
737^MAGD(2006.79,6,1,19,0)=" ; ** CAUTION ** 1st RARAD=12 or 15, 2nd RARAD=ien for file 200"
738^MAGD(2006.79,6,1,20,0)="XREF Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0),RADTIZ=9999999.9999-$P(RADFNZ,""^"",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,""^"",2),""DT"",RADTIZ,""P"",""B"",+$P(RADFNZ,""^"",4),0)),RADFNZ=+$P(RADFNZ,""^"",2),RADA=DA G Q:'RACNIZ"
739^MAGD(2006.79,6,1,21,0)=" S RARADOLD=RARAD ;save 1st value of rarad"
740^MAGD(2006.79,6,1,22,0)=" G Q:'$D(^RADPT(RADFNZ,""DT"",RADTIZ,""P"",RACNIZ,0)) S RARAD=+$P(^(0),""^"",RARAD) G Q:'RARAD"
741^MAGD(2006.79,6,1,23,0)=" ; ** CAUTION ** next line is reached 2 ways : from line above,"
742^MAGD(2006.79,6,1,24,0)=" ; and also from file 70.03, fld 15's ""ASTF"" xref"
743^MAGD(2006.79,6,1,25,0)=" ; thus RARAD's 2nd meaning must be preserved for XREF1"
744^MAGD(2006.79,6,1,26,0)="XREF1 S:$D(RASET) ^RARPT(RAXREF,RARAD,RADA)="""" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,RADA) D XPRI^RAUTL20"
745^MAGD(2006.79,6,1,27,0)="Q K RADA,RADFNZ,RADTIZ,RACNIZ,RARADOLD Q"
746^MAGD(2006.79,6,1,28,0)=" ;"
747^MAGD(2006.79,6,1,29,0)=" ;Checks for CONTRAST MEDIA given the necessary subscripts"
748^MAGD(2006.79,6,1,30,0)=" ;to access a record in File #70."
749^MAGD(2006.79,6,1,31,0)=" ;RADFN, RADTI, RACNI must be set."
750^MAGD(2006.79,6,1,32,0)=" ;Output is Y=a string delimited by commas containing all"
751^MAGD(2006.79,6,1,33,0)=" ;applicable items in externally formatted text (ex: If exam was"
752^MAGD(2006.79,6,1,34,0)=" ;done with contrast media Y=""CONTRAST MEDIA USED"""
753^MAGD(2006.79,6,1,35,0)=" ;06/16/99 remove obsolete RAF2"
754^MAGD(2006.79,6,1,36,0)=" ; add CPT Modifiers string"
755^MAGD(2006.79,6,1,37,0)=" ; output Y = procedure modifiers string"
756^MAGD(2006.79,6,1,38,0)=" ; Y(1)= CPT modifiers string, external"
757^MAGD(2006.79,6,1,39,0)=" ; Y(2)= CPT modifiers string, internal"
758^MAGD(2006.79,6,1,40,0)="MODS ;get procedure modifiers"
759^MAGD(2006.79,6,1,41,0)=" S (Y,Y(1),Y(2))="""" Q:'$D(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0)) S X=^(0)"
760^MAGD(2006.79,6,1,42,0)=" F I=0:0 S I=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""M"",I)) Q:I'>0 I $D(^RAMIS(71.2,+^(I,0),0)) S X1=$P(^(0),""^"") D MODS1"
761^MAGD(2006.79,6,1,43,0)=" S:$P(X,""^"",10)[""Y"" X1=""CONTRAST MEDIA USED"""
762^MAGD(2006.79,6,1,44,0)=" ;"
763^MAGD(2006.79,6,1,45,0)="MODS0 ;falls through from MODS; get CPT modifiers"
764^MAGD(2006.79,6,1,46,0)=" S:Y="""" Y=""None"""
765^MAGD(2006.79,6,1,47,0)=" S X=^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0),I=0"
766^MAGD(2006.79,6,1,48,0)=" F S I=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,""CMOD"",I)) Q:I'>0 S X1=$$BASICMOD^RACPTMSC(+$G(^(I,0)),DT) I +X1>0 S Y(1)=Y(1)_$S(Y(1)="""":"""",1:"", "")_$P(X1,""^"",2),Y(2)=Y(2)_$S(Y(2)="""":"""",1:"", "")_$P(X1,""^"")"
767^MAGD(2006.79,6,1,49,0)=" S:Y(1)="""" Y(1)=""None"""
768^MAGD(2006.79,6,1,50,0)=" K I,X,X1 Q"
769^MAGD(2006.79,6,1,51,0)=" ;"
770^MAGD(2006.79,6,1,52,0)="MODS1 ;builds procedure modifier string (called from MODS above)"
771^MAGD(2006.79,6,1,53,0)=" S Y=Y_$S(Y="""":"""",1:"", "")_X1 Q"
772^MAGD(2006.79,6,1,54,0)=" ;"
773^MAGD(2006.79,6,1,55,0)=" ;called to do some order checks - takes appropriate action if:"
774^MAGD(2006.79,6,1,56,0)=" ; procedure requested needs Rad/NM physician approval (File 71, fld 11)"
775^MAGD(2006.79,6,1,57,0)=" ; there are other outstanding orders for this procedure for this pt"
776^MAGD(2006.79,6,1,58,0)=" ; user is inactivated (file 200, ""I"" node)"
777^MAGD(2006.79,6,1,59,0)="ORDPRC I $D(^RAMIS(71,+X,0)),$P(^(0),""^"",11)[""y"" D CHKUSR I 'RAMSG W !!,""Please contact appropriate Imaging Service to request this procedure! "" K X,RAMSG Q"
778^MAGD(2006.79,6,1,60,0)=" S RAS3=+$P(^RAO(75.1,DA,0),""^"")"
779^MAGD(2006.79,6,1,61,0)="ORDPRC1 Q:'$D(^RAO(75.1,""AP"",RAS3,X)) S RAS4=X,RASCNT=0 K RAX"
780^MAGD(2006.79,6,1,62,0)=" F RAS5=0:0 S RAS5=$O(^RAO(75.1,""AP"",RAS3,RAS4,RAS5)) Q:'RAS5 F RAS6=0:0 S RAS6=$O(^RAO(75.1,""AP"",RAS3,RAS4,RAS5,RAS6)) Q:'RAS6 I $D(^RAO(75.1,RAS6,0)) S RAT=+$P(^(0),""^"",5) I RAT>2 S RASCNT=RASCNT+1 D:$S('$D(RAQUIT):1,1:RASCNT>1) ORDMES"
781^MAGD(2006.79,6,1,63,0)=" I $D(RAX),'$D(RAQUIT) D ORDMES1"
782^MAGD(2006.79,6,1,64,0)=" K:$D(RAX) RAQUIT K RAMSG,RAS3,RAS4,RAS5,RAS6,RASCNT,RAT,RAX Q"
783^MAGD(2006.79,6,1,65,0)=" ;"
784^MAGD(2006.79,6,1,66,0)="CHKUSR ; Check if valid user"
785^MAGD(2006.79,6,1,67,0)=" N RAINADT,RAC"
786^MAGD(2006.79,6,1,68,0)=" S RAINADT=+$P($G(^VA(200,+$G(DUZ),""PS"")),""^"",4)"
787^MAGD(2006.79,6,1,69,0)=" S RAC=$O(^VA(200,+$G(DUZ),""RAC"",0))"
788^MAGD(2006.79,6,1,70,0)=" S RAMSG=$S('($D(DUZ)#2):0,'$D(^VA(200,DUZ,0)):0,'RAC:0,'RAINADT:1,'$D(DT):0,DT'>RAINADT:1,1:0)"
789^MAGD(2006.79,6,1,71,0)=" Q"
790^MAGD(2006.79,6,1,72,0)="ORDMES W:'$D(RAX) !!,*7,""The following requests are already on file for this procedure:"",!"
791^MAGD(2006.79,6,1,73,0)=" W !?3,""A request dated "" S Y=9999999.9999-RAS5 D DT^DIO2 W "" is already "",$S(RAT=3:""on "",1:""""),$P($P(^DD(75.1,5,0),RAT_"":"",2),"";""),"" for this procedure."" S RAX=1 Q"
792^MAGD(2006.79,6,1,74,0)="ORDMES1 W !!?3,""Is it ok to continue? No// "" R RAX:DTIME S:'$T!(RAX="""")!(RAX[""^"") RAX=""N"""
793^MAGD(2006.79,6,1,75,0)=" I ""Nn""[$E(RAX) K X S RAPRI=0"
794^MAGD(2006.79,6,1,76,0)=" I $D(X),""Yy""'[$E(RAX) W !!?3,""Enter 'YES' to request this procedure for this patient, or 'NO' not to."",! G ORDMES1"
795^MAGD(2006.79,6,1,77,0)=" Q"
796^MAGD(2006.79,6,1,78,0)=" ;"
797^MAGD(2006.79,6,1,79,0)=" ;Called (from RAPSET) to determine if at least one division and at"
798^MAGD(2006.79,6,1,80,0)=" ;least one location are set up. Can't use pkg unless these are set up."
799^MAGD(2006.79,6,1,81,0)="CHKSP S RADV=$S($O(^RA(79,0))>0:1,1:0),RALC=$S($D(^RA(79.1,+$O(^RA(79,""AL"",0)),0)):1,1:0)"
800^MAGD(2006.79,6,1,82,0)=" Q"
801^MAGD(2006.79,6,1,83,0)=" ;"
802^MAGD(2006.79,6,1,84,0)="KILLVAR ;This call will clean up possible variables left after execution"
803^MAGD(2006.79,6,1,85,0)=" ;of the Label print fields in file 78.7"
804^MAGD(2006.79,6,1,86,0)=" K RAY0,RAY1,RAY2,RAY3,RAGE,RACSE,RANOW,RADOB,RAEXDT,RATRAN,RARPDT,RADIAG,RAMOD,RAINST,RAEXLST,RAVST,RALCSE,RANM,RAPAGE,RAPR,RAL,RARST,RAREA,RADOC,RARAD,RASSN"
805^MAGD(2006.79,6,1,87,0)=" K RASTAFF,RASIGS,RATECH,RACTY,RASIGVES,RAVER,RASIGVS,RASIGVSB,RASIGR,RASERV,RASEX,RAS,RAII,RAFMT,RASV"
806^MAGD(2006.79,6,1,88,0)=" Q"
807^MAGD(2006.79,6,1,89,0)=" ;"
808^MAGD(2006.79,6,1,90,0)="CONTRAST(RAZ71) ;Display the contrast media/medium associated with a Rad/Nuc"
809^MAGD(2006.79,6,1,91,0)=" ;Med Procedure. Called from: PRC1^RAUTL8 & ALLERGY^RAORD1"
810^MAGD(2006.79,6,1,92,0)=" ;input: RAZ71=ien of the non-parent procedure in file 71"
811^MAGD(2006.79,6,1,93,0)=" ;"
812^MAGD(2006.79,6,1,94,0)=" K RAZCM S RAZ71(0)=$G(^RAMIS(71,RAZ71,0))"
813^MAGD(2006.79,6,1,95,0)=" S RAZCMU=$P(RAZ71(0),""^"",20) ;is contrast media used?"
814^MAGD(2006.79,6,1,96,0)=" I RAZCMU'=""Y"" K RAZCMU Q"
815^MAGD(2006.79,6,1,97,0)=" D GETS^DIQ(71,RAZ71_"","",""125*"",""E"",""RAZCM"")"
816^MAGD(2006.79,6,1,98,0)=" ; The RAZCM(71.0125,x,.01,""E"") array will be one or more of following"
817^MAGD(2006.79,6,1,99,0)=" ; values: I:Iodinated contrast, ionic;N:Iodinated contrast, non-ionic"
818^MAGD(2006.79,6,1,100,0)=" ; L:Gadolinium, C:Cholecystogram;G:Gastrografin;B:Barium"
819^MAGD(2006.79,6,1,101,0)=" ;"
820^MAGD(2006.79,6,1,102,0)=" S:$O(RAZCM(71.0125,$C(126)),-1)=$O(RAZCM(71.0125,"""")) RAZTAG=""medium"""
821^MAGD(2006.79,6,1,103,0)=" S:'$D(RAZTAG)#2 RAZTAG=""media"""
822^MAGD(2006.79,6,1,104,0)=" S RAPMSG(1)=""************** Patient reaction to contrast ""_RAZTAG_"" *************"""
823^MAGD(2006.79,6,1,105,0)=" S RAPMSG(2)=$E($P(RAZ71(0),""^""),1,47)_"" uses contrast ""_RAZTAG_"": """
824^MAGD(2006.79,6,1,106,0)=" S RAPMSG(2,""F"")=""!"",RAZI="""",RAZSUB=$O(RAPMSG($C(32)),-1)"
825^MAGD(2006.79,6,1,107,0)=" F S RAZI=$O(RAZCM(71.0125,RAZI)) Q:RAZI="""" D"
826^MAGD(2006.79,6,1,108,0)=" .S:$L($G(RAPMSG(RAZSUB)))+$L(RAZCM(71.0125,RAZI,.01,""E""))>69 RAZSUB=RAZSUB+1"
827^MAGD(2006.79,6,1,109,0)=" .S RAPMSG(RAZSUB)=$G(RAPMSG(RAZSUB))_RAZCM(71.0125,RAZI,.01,""E"")_"", """
828^MAGD(2006.79,6,1,110,0)=" .Q"
829^MAGD(2006.79,6,1,111,0)=" ; The reverse dollar order (R$O) is used to strip off the "", "" string"
830^MAGD(2006.79,6,1,112,0)=" ; from the last printable subscript containing CM data. I also use the"
831^MAGD(2006.79,6,1,113,0)=" ; R$O to set my last printable array element to '*'s to box off the"
832^MAGD(2006.79,6,1,114,0)=" ; warning."
833^MAGD(2006.79,6,1,115,0)=" S RAPMSG($O(RAPMSG($C(32)),-1))=$E(RAPMSG($O(RAPMSG($C(32)),-1)),1,$L(RAPMSG($O(RAPMSG($C(32)),-1)))-2) ;strips off the "", """
834^MAGD(2006.79,6,1,116,0)=" S $P(RAPMSG($O(RAPMSG($C(32)),-1)+1),""*"",69)="""",RAPMSG(99)="" """
835^MAGD(2006.79,6,1,117,0)=" D EN^DDIOL(.RAPMSG)"
836^MAGD(2006.79,6,1,118,0)=" K RAPMSG,RAZCM,RAZCMU,RAZI,RAZTAG,RAZSUB"
837^MAGD(2006.79,6,1,119,0)=" Q"
838^MAGD(2006.79,6,1,120,0)=" ;"
839^MAGD(2006.79,6,1,121,0)="DELCM(DA) ;Ask the user if he/she is sure that deletion of contrast media"
840^MAGD(2006.79,6,1,122,0)=" ;is intended. If the user enter '^' exit editng the template"
841^MAGD(2006.79,6,1,123,0)=" ; input: DA=the ien of the record in file 71"
842^MAGD(2006.79,6,1,124,0)=" ;output: RAYN=response to 'Are you sure?'; either 'Y', 'N', or '^' "
843^MAGD(2006.79,6,1,125,0)=" ;Called from the RA PROCEDURE EDIT input template (RA*5*45)"
844^MAGD(2006.79,6,1,126,0)=" N RAYN W !?3,""*** Deleting all contrast media data associated with this procedure. ***"""
845^MAGD(2006.79,6,1,127,0)=" F D Q:$L($G(RAYN))"
846^MAGD(2006.79,6,1,128,0)=" .R !!?3,""All contrast relationships with this procedure will be deleted."",!?3,""Are you sure you want to delete? N// "",RAYN:DTIME"
847^MAGD(2006.79,6,1,129,0)=" .S:'$T!(RAYN[""^"") RAYN=""^"" Q:RAYN=""^"""
848^MAGD(2006.79,6,1,130,0)=" .S:RAYN="""" RAYN=""N"" Q:RAYN=""N"""
849^MAGD(2006.79,6,1,131,0)=" .S RAYN=$$UP^XLFSTR($E(RAYN)) Q:RAYN=""Y""!(RAYN=""N"")"
850^MAGD(2006.79,6,1,132,0)=" .I RAYN[""?"" W !?3,""Enter 'Y'es to delete associated contrasts, or 'N'o to preserve associated"",!?3,""contrasts."" K RAYN Q"
851^MAGD(2006.79,6,1,133,0)=" .K RAYN W !?3,""Please enter 'Y' for yes, or 'N' for no."""
852^MAGD(2006.79,6,1,134,0)=" .Q"
853^MAGD(2006.79,6,1,135,0)=" ;The user does not want to delete associated cm data or has '^' out of"
854^MAGD(2006.79,6,1,136,0)=" ;the option. We must reset the CONTRAST MEDIA USED (#20) field back to"
855^MAGD(2006.79,6,1,137,0)=" ;yes from no."
856^MAGD(2006.79,6,1,138,0)=" I RAYN'=""Y"" D"
857^MAGD(2006.79,6,1,139,0)=" .K RAFDA S RAFDA(71,DA_"","",20)=""Y"" D FILE^DIE("""",""RAFDA"")"
858^MAGD(2006.79,6,1,140,0)=" .K RAFDA Q"
859^MAGD(2006.79,6,1,141,0)=" Q RAYN"
860^MAGD(2006.79,6,1,142,0)=" ;"
861^MAGD(2006.79,7,0)="RAUTL20^3050311.125836"
862^MAGD(2006.79,7,1,0)="^2006.791^128^128"
863^MAGD(2006.79,7,1,1,0)="RAUTL20 ;HISC/SWM-Utility Routine ;6/16/97 14:27"
864^MAGD(2006.79,7,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;**5,34**;Mar 16, 1998"
865^MAGD(2006.79,7,1,3,0)=" ;"
866^MAGD(2006.79,7,1,4,0)="EN1 ; for displaying + and . during case lookup"
867^MAGD(2006.79,7,1,5,0)=" S RAPRTSET=0"
868^MAGD(2006.79,7,1,6,0)=" Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))"
869^MAGD(2006.79,7,1,7,0)=" Q:RADFN=""""!(RADTI="""")!(RACNI="""")"
870^MAGD(2006.79,7,1,8,0)=" ; output : RAPRTSET=1 : case is part of a combined PRINTset, & flag it"
871^MAGD(2006.79,7,1,9,0)=" ; RAMEMLOW=1 : case is lowest ien of print set AND flag it"
872^MAGD(2006.79,7,1,10,0)=" N RA1,RA2,RA3,RA4,RA5,RA6,RA7,RACN S RA1="""",RA3=""A"",RA5=0"
873^MAGD(2006.79,7,1,11,0)=" S RACN=+$G(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0))"
874^MAGD(2006.79,7,1,12,0)=" S RAMEMLOW=0"
875^MAGD(2006.79,7,1,13,0)=" S RAPRTSET=$P($G(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0)),""^"",25)=2"
876^MAGD(2006.79,7,1,14,0)=" Q:'RAPRTSET"
877^MAGD(2006.79,7,1,15,0)=" ; put + infront of lowest ien of case that has MEMBER OF SET = 2"
878^MAGD(2006.79,7,1,16,0)=" F S RA1=$O(^RADPT(RADFN,""DT"",RADTI,""P"",RA1)) Q:RA1="""" Q:$P($G(^(RA1,0)),U,25)=2 ; RA1 is at lowest ien with MEMBER OF SET = 2"
879^MAGD(2006.79,7,1,17,0)=" S:RACNI=RA1 RAMEMLOW=1"
880^MAGD(2006.79,7,1,18,0)=" S RA1="""" F S RA1=$O(^RADPT(RADFN,""DT"",RADTI,""P"",""B"",RA1)) Q:RA1="""" D LOOP1"
881^MAGD(2006.79,7,1,19,0)=" I RA5 S RAPRTSET=0,RAMEMLOW=0 ;don't display if ptrs to #74 differ within set"
882^MAGD(2006.79,7,1,20,0)=" Q"
883^MAGD(2006.79,7,1,21,0)="LOOP1 ; RA1= : for-loop var"
884^MAGD(2006.79,7,1,22,0)=" ; RA2= : (1) ien for 70.03 (2) also, pointer value to file #74"
885^MAGD(2006.79,7,1,23,0)=" ; RA3= : holds earliest case with pointer value to file #74"
886^MAGD(2006.79,7,1,24,0)=" ; RA4= : (ienof #70.03)=case number^procedure pointers^ptr #74"
887^MAGD(2006.79,7,1,25,0)=" ; RA5=0 : all cases in set point to same non-null rarpt() or all null"
888^MAGD(2006.79,7,1,26,0)=" ; regardless of cancelled status"
889^MAGD(2006.79,7,1,27,0)=" ; RA5<>0: one or more cases in set point to different rarpt()"
890^MAGD(2006.79,7,1,28,0)=" ; RA6= : pointer to file #72 examination status"
891^MAGD(2006.79,7,1,29,0)=" ; RA7=1 : denote call of LOOP1 came from EN2 and not from EN1"
892^MAGD(2006.79,7,1,30,0)=" S RA2=$O(^RADPT(RADFN,""DT"",RADTI,""P"",""B"",RA1,0))"
893^MAGD(2006.79,7,1,31,0)=" ; skip rec if it's not part of combined report"
894^MAGD(2006.79,7,1,32,0)=" Q:$P(^RADPT(RADFN,""DT"",RADTI,""P"",RA2,0),""^"",25)'=2"
895^MAGD(2006.79,7,1,33,0)=" S:$G(RA7) RA4=RA2,RA4(RA4)=RA1"
896^MAGD(2006.79,7,1,34,0)=" S RA2=$P(^RADPT(RADFN,""DT"",RADTI,""P"",RA2,0),""^"",17),RA6=$P(^(0),""^"",3) S:$G(RA7) RA4(RA4)=RA4(RA4)_""^""_$P(^(0),""^"",2)_""^""_$P(^(0),""^"",17)_""^""_$P(^(0),""^"",3)"
897^MAGD(2006.79,7,1,35,0)=" ; skip if exm canc'd & exm's pc 17 is null"
898^MAGD(2006.79,7,1,36,0)=" I $P($G(^RA(72,+RA6,0)),""^"",3)=0,RA2="""" Q"
899^MAGD(2006.79,7,1,37,0)=" S:RA3=""A"" RA3=RA2"
900^MAGD(2006.79,7,1,38,0)=" I RA5=0,RA2]"""" S RA5=RA2-RA3"
901^MAGD(2006.79,7,1,39,0)=" Q"
902^MAGD(2006.79,7,1,40,0)="EN2(RA4) ; display all print members' procs during report editing/printg"
903^MAGD(2006.79,7,1,41,0)=" S RAPRTSET=0"
904^MAGD(2006.79,7,1,42,0)=" Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))"
905^MAGD(2006.79,7,1,43,0)=" Q:RADFN=""""!(RADTI="""")!(RACNI="""")"
906^MAGD(2006.79,7,1,44,0)=" ; output : RA4(IEN OF #70.03)=CASE NUMBER^IEN OF #71 (procedure)^ptr #74"
907^MAGD(2006.79,7,1,45,0)=" ; ^exm stat"
908^MAGD(2006.79,7,1,46,0)=" ; RAPRTSET = 1 : case is part of a combined PRINTset"
909^MAGD(2006.79,7,1,47,0)=" N RA1,RA2,RA3,RA5,RA6,RA7 S RA1="""",RA3=""A"",RA5=0,RA7=1"
910^MAGD(2006.79,7,1,48,0)=" F S RA1=$O(RA4(RA1)) Q:RA1="""" K RA4(RA1) ;clean up array"
911^MAGD(2006.79,7,1,49,0)=" S RAPRTSET=$P($G(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0)),""^"",25)=2"
912^MAGD(2006.79,7,1,50,0)=" Q:'RAPRTSET"
913^MAGD(2006.79,7,1,51,0)=" F S RA1=$O(^RADPT(RADFN,""DT"",RADTI,""P"",""B"",RA1)) Q:RA1="""" D LOOP1"
914^MAGD(2006.79,7,1,52,0)=" I RA5 S RAPRTSET=0 ;don't display if ptrs to #74 differ within set"
915^MAGD(2006.79,7,1,53,0)=" Q"
916^MAGD(2006.79,7,1,54,0)="EN3(RA4) ; for print set, AFTER record is created in rarpt()"
917^MAGD(2006.79,7,1,55,0)=" Q:'$D(RADFN)!('$D(RADTI))"
918^MAGD(2006.79,7,1,56,0)=" Q:RADFN=""""!(RADTI="""")"
919^MAGD(2006.79,7,1,57,0)=" ; output :RA4(IEN OF #70.03)=CASE NUMBER (ONLY THOSE CASES FROM #74.05)"
920^MAGD(2006.79,7,1,58,0)=" N RA1,RA2,RA3,RA5 S RA1="""",RA3=""A"""
921^MAGD(2006.79,7,1,59,0)=" F S RA1=$O(RA4(RA1)) Q:RA1="""" K RA4(RA1) ;clean up array"
922^MAGD(2006.79,7,1,60,0)=" S RA5=$S($G(RARPT):RARPT,$G(RAIEN):RAIEN,1:0) Q:RA5=0"
923^MAGD(2006.79,7,1,61,0)=" F S RA1=$O(^RARPT(RA5,1,""B"",RA1)) Q:RA1="""" S RA2=$P(RA1,""-"",2),RA3=$O(^RADPT(RADFN,""DT"",RADTI,""P"",""B"",RA2,0)),RA4(RA3)=RA2"
924^MAGD(2006.79,7,1,62,0)=" Q"
925^MAGD(2006.79,7,1,63,0)="XPRI ;loop thru sub-file #74.05 to set/kill prim. xref for other prt members"
926^MAGD(2006.79,7,1,64,0)=" Q:'$D(RADFNZ)!('$D(RADTIZ))!('$D(RARAD))!('$D(RAXREF))!('$D(DA))"
927^MAGD(2006.79,7,1,65,0)=" Q:$O(^RARPT(DA,1,""B"",0))="""""
928^MAGD(2006.79,7,1,66,0)=" N RA1,RA200 S RA1="""""
929^MAGD(2006.79,7,1,67,0)="XPRI1 S RA1=$O(^RARPT(DA,1,""B"",RA1)) Q:RA1="""""
930^MAGD(2006.79,7,1,68,0)=" S RACNIZ=$O(^RADPT(RADFNZ,""DT"",RADTIZ,""P"",""B"",$P(RA1,""-"",2),0))"
931^MAGD(2006.79,7,1,69,0)=" G:'$D(^RADPT(RADFNZ,""DT"",RADTIZ,""P"",RACNIZ,0)) XPRI1 S RA200=+$P(^(0),""^"",RARADOLD) ; use raradold to get piece number in ""p"" node"
932^MAGD(2006.79,7,1,70,0)=" G XPRI1:'RA200"
933^MAGD(2006.79,7,1,71,0)=" S:$D(RASET) ^RARPT(RAXREF,RA200,DA)="""""
934^MAGD(2006.79,7,1,72,0)=" K:$D(RAKILL) ^RARPT(RAXREF,RA200,DA)"
935^MAGD(2006.79,7,1,73,0)=" G XPRI1"
936^MAGD(2006.79,7,1,74,0)="XSEC ;loop thru sub-file #74.05 to set/kill sec. xref for other print members"
937^MAGD(2006.79,7,1,75,0)=" Q:'$D(RADFNZ)!('$D(RADTIZ))!('$D(RASECOND))!('$D(RAXREF))!('$D(DA))"
938^MAGD(2006.79,7,1,76,0)=" Q:$O(^RARPT(DA,1,""B"",0))="""""
939^MAGD(2006.79,7,1,77,0)=" N RA1,RA2,RA200 S RA1="""""
940^MAGD(2006.79,7,1,78,0)="XSEC1 S RA1=$O(^RARPT(DA,1,""B"",RA1)) Q:RA1="""""
941^MAGD(2006.79,7,1,79,0)=" S RACNIZ=$O(^RADPT(RADFNZ,""DT"",RADTIZ,""P"",""B"",$P(RA1,""-"",2),0))"
942^MAGD(2006.79,7,1,80,0)=" G:'$D(^RADPT(RADFNZ,""DT"",RADTIZ,""P"",RACNIZ,0)) XSEC1 G:'$D(^(RASECOND,0)) XSEC1"
943^MAGD(2006.79,7,1,81,0)=" S RA2=0"
944^MAGD(2006.79,7,1,82,0)="XSEC2 S RA2=$O(^RADPT(RADFNZ,""DT"",RADTIZ,""P"",RACNIZ,RASECOND,RA2)) G:'+RA2 XSEC1 S RA200=+$G(^(RA2,0))"
945^MAGD(2006.79,7,1,83,0)=" G:'RA200 XSEC2"
946^MAGD(2006.79,7,1,84,0)=" S:$D(RASET) ^RARPT(RAXREF,RA200,DA)="""""
947^MAGD(2006.79,7,1,85,0)=" K:$D(RAKILL) ^RARPT(RAXREF,RA200,DA)"
948^MAGD(2006.79,7,1,86,0)=" G XSEC2"
949^MAGD(2006.79,7,1,87,0)="FLAGMEM() ;in distr list, print + if case is part of a print set"
950^MAGD(2006.79,7,1,88,0)=" ; called from File #74's print templates"
951^MAGD(2006.79,7,1,89,0)=" N RA1 S RA1="""""
952^MAGD(2006.79,7,1,90,0)=" I '$D(D0) Q RA1"
953^MAGD(2006.79,7,1,91,0)=" S RA1=$P($G(^RABTCH(74.4,D0,0)),U) I RA1="""" Q RA1"
954^MAGD(2006.79,7,1,92,0)=" S RA1=$O(^RARPT(RA1,1,""B"",0)) S:RA1]"""" RA1=""+"""
955^MAGD(2006.79,7,1,93,0)=" Q RA1"
956^MAGD(2006.79,7,1,94,0)="DELPNT(RADFN,RADTI,RACNI) ; When an exam is cancelled & it is associated"
957^MAGD(2006.79,7,1,95,0)=" ; with data in the Nuc Med Exam Data file (70.2) ask the user if this"
958^MAGD(2006.79,7,1,96,0)=" ; pointer to 70.2 is to be deleted. Also delete the flag which"
959^MAGD(2006.79,7,1,97,0)=" ; indicates that the dosage ticket had printed for this exam."
960^MAGD(2006.79,7,1,98,0)=" ; Called from CANCEL^RAEDCN"
961^MAGD(2006.79,7,1,99,0)=" ; Input: RADFN - Internal Entry Number (IEN) of the Patient."
962^MAGD(2006.79,7,1,100,0)=" ; RADTI - Date/Time of the examination (inverse format)"
963^MAGD(2006.79,7,1,101,0)=" ; RACNI - IEN of the exam for this date/time"
964^MAGD(2006.79,7,1,102,0)=" ;"
965^MAGD(2006.79,7,1,103,0)=" ;- Delete entry in 'Dosage Ticket Printed?' field DD: 70.03, field: 29 -"
966^MAGD(2006.79,7,1,104,0)=" N RAFDA S RAFDA(70.03,RACNI_"",""_RADTI_"",""_RADFN_"","",29)=""@"""
967^MAGD(2006.79,7,1,105,0)=" D FILE^DIE("""",""RAFDA"")"
968^MAGD(2006.79,7,1,106,0)=" ;----------------------------------------------------------------------"
969^MAGD(2006.79,7,1,107,0)=" Q:'+$P(^RADPT(RADFN,""DT"",RADTI,""P"",RACNI,0),""^"",28) ;no NucMed Xam data"
970^MAGD(2006.79,7,1,108,0)=" K RAFDA N RAYN"
971^MAGD(2006.79,7,1,109,0)=" F D Q:RAYN]"""""
972^MAGD(2006.79,7,1,110,0)=" . R !!?3,""Do you wish to delete the radiopharmaceutical data associated"",!?3,""with this exam? No//"",RAYN:DTIME"
973^MAGD(2006.79,7,1,111,0)=" . I RAYN[""^""!('$T) S RAYN=""^"" Q ;don't delete pntr if '^' or timeout"
974^MAGD(2006.79,7,1,112,0)=" . S RAYN=$E(RAYN) S:RAYN="""" RAYN=""N"""
975^MAGD(2006.79,7,1,113,0)=" . S RAYN=$$UP^XLFSTR(RAYN) Q:RAYN=""N"" ;exit, don't del 70.2 pnt"
976^MAGD(2006.79,7,1,114,0)=" . I RAYN=""Y"" D Q ; delete the pointer to 70.2, then quit"
977^MAGD(2006.79,7,1,115,0)=" .. N RAFDA S RAFDA(70.03,RACNI_"",""_RADTI_"",""_RADFN_"","",500)=""@"""
978^MAGD(2006.79,7,1,116,0)=" .. D FILE^DIE("""",""RAFDA"")"
979^MAGD(2006.79,7,1,117,0)=" .. ; NOTE: This silent FileMan call not only deletes the pointer to"
980^MAGD(2006.79,7,1,118,0)=" .. ; the entry in the Nuc Med Exam Data file (70.2), but the"
981^MAGD(2006.79,7,1,119,0)=" .. ; entry in 70.2 itself. This is because a M X-Ref exists on"
982^MAGD(2006.79,7,1,120,0)=" .. ; the field which points to file 70.2 that also deletes the"
983^MAGD(2006.79,7,1,121,0)=" .. ; entry in the Nuc Med Exam Data file. Please refer to"
984^MAGD(2006.79,7,1,122,0)=" .. ; ^DD(70.03,500,.. for more information."
985^MAGD(2006.79,7,1,123,0)=" .. Q"
986^MAGD(2006.79,7,1,124,0)=" . W !!?3,""Enter 'Yes' to delete the radiopharmaceutical data associated with this exam."",!?3,""Enter 'No' to preserve the radiopharmaceutical data associated with this"",!?3,""exam. """
987^MAGD(2006.79,7,1,125,0)=" . W ""Enter '^' to exit without deleting the radiopharmaceutical data"",!?3,""associated with this exam."",$C(7)"
988^MAGD(2006.79,7,1,126,0)=" . S RAYN="""""
989^MAGD(2006.79,7,1,127,0)=" . Q"
990^MAGD(2006.79,7,1,128,0)=" Q"
991^MAGD(2006.79,8,0)="RAUTL3^3050311.125836"
992^MAGD(2006.79,8,1,0)="^2006.791^61^61"
993^MAGD(2006.79,8,1,1,0)="RAUTL3 ;HISC/CAH,FPT,GJC AISC/SAW-Utility for Callable Entry Points ;4/1/97 10:04"
994^MAGD(2006.79,8,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;**26**;Mar 16, 1998"
995^MAGD(2006.79,8,1,3,0)="EN1 ;ENTRY POINT FOR AMIE CALL"
996^MAGD(2006.79,8,1,4,0)=" ;Requires four input variables"
997^MAGD(2006.79,8,1,5,0)=" ; DFN = Patient internal entry number"
998^MAGD(2006.79,8,1,6,0)=" ; Date range for report in Fileman internal format"
999^MAGD(2006.79,8,1,7,0)=" ; RABDT = Beginning Date (time optional)"
1000^MAGD(2006.79,8,1,8,0)=" ; RAEDT = Ending Date (time optional)"
1001^MAGD(2006.79,8,1,9,0)=" ; Exam locations (from file 44, Hospital Location) that are to be"
1002^MAGD(2006.79,8,1,10,0)=" ; included in the report"
1003^MAGD(2006.79,8,1,11,0)=" ; RAHLOC = A string of internal entry numbers for locations"
1004^MAGD(2006.79,8,1,12,0)=" ; Each location separated by ^ and RAHLOC must begin"
1005^MAGD(2006.79,8,1,13,0)=" ; and end with an ^ (e.g., RAHLOC=^3^ or RAHLOC=^56^75^)"
1006^MAGD(2006.79,8,1,14,0)=" ; These are REQUESTING locations, not imaging locations"
1007^MAGD(2006.79,8,1,15,0)=" ;"
1008^MAGD(2006.79,8,1,16,0)=" I '$D(DFN)!('$D(RAHLOC))!('$D(RABDT))!('$D(RAEDT)) W !!,""Required variables are not defined. Unable to continue."",*7 Q"
1009^MAGD(2006.79,8,1,17,0)=" S RAMIE=1 F RAPTR=RABDT-.0000001:0 S RAPTR=$O(^RADPT(DFN,""DT"",""B"",RAPTR)) Q:RAPTR'>0!(RAPTR>RAEDT) S RAPTR1=$O(^(RAPTR,0)) I RAPTR1 F RAPTR2=0:0 S RAPTR2=$O(^RADPT(DFN,""DT"",RAPTR1,""P"",RAPTR2)) Q:RAPTR2'>0 I $D(^(RAPTR2,0)) S RAEX=^(0) D CHK"
1010^MAGD(2006.79,8,1,18,0)=" K RACNI,RAEX,RAII,RAK,RAMDIV,RAMDV,RAMLC,RAMIE,RANUM,RAPT1,RAPTR,RAPTR1,RAPTR2,RASSN,RAST Q"
1011^MAGD(2006.79,8,1,19,0)="CHK I $P(RAEX,U,17),RAHLOC[(U_$P(RAEX,U,22)_U) S RAST=$S($D(^RARPT($P(RAEX,""^"",17),0)):^(0),1:"""") I ""VR""[$P(RAST,""^"",5) S RARPT=$P(RAEX,""^"",17),RAPT1=1 D ^RARTR F RAK=0:0 S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 I $D(^(RAK,0)) K @$P(^(0),""^"",5)"
1012^MAGD(2006.79,8,1,20,0)=" Q"
1013^MAGD(2006.79,8,1,21,0)="SIGNON ;Check the # of reports to either pre-verify of verify."
1014^MAGD(2006.79,8,1,22,0)=" Q:'$D(DUZ)#2 N RA74,X0,X1,Y1 S (X0,X1,Y1)=0"
1015^MAGD(2006.79,8,1,23,0)=" ; first, tabulate # (Y1) of reports to pre-verify (if any)"
1016^MAGD(2006.79,8,1,24,0)=" F S X0=$O(^RARPT(""ARES"",DUZ,X0)) Q:X0'>0 D"
1017^MAGD(2006.79,8,1,25,0)=" . S RA74=$G(^RARPT(X0,0))"
1018^MAGD(2006.79,8,1,26,0)=" . Q:$$STUB^RAEDCN1(X0) ; skip stub report 031501"
1019^MAGD(2006.79,8,1,27,0)=" . Q:$P(RA74,""^"",5)=""V"" ; skip if already verified"
1020^MAGD(2006.79,8,1,28,0)=" . S:$P(RA74,""^"",12)']"""" Y1=Y1+1"
1021^MAGD(2006.79,8,1,29,0)=" . Q"
1022^MAGD(2006.79,8,1,30,0)=" S:Y1 X0=""!*** You have ""_Y1_"" imaging report""_$S(Y1>1:""s"",1:"""")_"" to pre-verify. ***"""
1023^MAGD(2006.79,8,1,31,0)=" D:Y1 SET^XUS1A(X0)"
1024^MAGD(2006.79,8,1,32,0)=" ; next tabulate # (X1) of reports to verify (if any)"
1025^MAGD(2006.79,8,1,33,0)=" S X0=0 F S X0=$O(^RARPT(""ASTF"",DUZ,X0)) Q:X0'>0 D"
1026^MAGD(2006.79,8,1,34,0)=" . S RA74=$G(^RARPT(X0,0))"
1027^MAGD(2006.79,8,1,35,0)=" . Q:$$STUB^RAEDCN1(X0) ; skip stub report 031501"
1028^MAGD(2006.79,8,1,36,0)=" . Q:$P(RA74,""^"",5)=""V"" ; skip if already verified"
1029^MAGD(2006.79,8,1,37,0)=" . S X1=X1+1"
1030^MAGD(2006.79,8,1,38,0)=" Q:X1'>0"
1031^MAGD(2006.79,8,1,39,0)=" S X0=""!*** You have ""_X1_"" imaging report""_$S(X1>1:""s"",1:"""")_"" to verify. ***"""
1032^MAGD(2006.79,8,1,40,0)=" D SET^XUS1A(X0)"
1033^MAGD(2006.79,8,1,41,0)=" Q"
1034^MAGD(2006.79,8,1,42,0)="UPDT(RANODE) ; Delete blank lines for Rad/Nuc Med Word Processing fields."
1035^MAGD(2006.79,8,1,43,0)=" ; These 'blank' consist of nothing more than spaces."
1036^MAGD(2006.79,8,1,44,0)=" ; 'RANODE' is the data node to be examined: i.e, for Clinical History"
1037^MAGD(2006.79,8,1,45,0)=" ; in Rad/Nuc Med Orders (75.1) RANODE=""^RAO(75.1,""_DA_"",H,"""
1038^MAGD(2006.79,8,1,46,0)=" ; -or in Rad/Nuc Med Reports (74) RANODE=""^RARPT(DA_"",R,"""
1039^MAGD(2006.79,8,1,47,0)=" ; "
1040^MAGD(2006.79,8,1,48,0)=" N RA0,RACNT,RAI,RATCNT,RAXIT,RAY"
1041^MAGD(2006.79,8,1,49,0)=" S (RACNT,RATCNT,RAXIT)=0 S RAI=999999999"
1042^MAGD(2006.79,8,1,50,0)=" S RAY=$G(@(RANODE_""0)"")),RAY(4)=+$P(RAY,""^"",4) Q:'RAY(4)"
1043^MAGD(2006.79,8,1,51,0)=" F S RAI=$O(@(RANODE_RAI_"")""),-1) Q:RAI'>0 D Q:RAXIT"
1044^MAGD(2006.79,8,1,52,0)=" . S RA0=$G(@(RANODE_RAI_"",0)""))"
1045^MAGD(2006.79,8,1,53,0)=" . I RA0?1.999"" "" D"
1046^MAGD(2006.79,8,1,54,0)=" .. K @(RANODE_RAI_"",0)"") S RACNT=RACNT+1"
1047^MAGD(2006.79,8,1,55,0)=" . E S RAXIT=1"
1048^MAGD(2006.79,8,1,56,0)=" . Q"
1049^MAGD(2006.79,8,1,57,0)=" I RACNT D"
1050^MAGD(2006.79,8,1,58,0)=" . S RATCNT=RAY(4)-RACNT"
1051^MAGD(2006.79,8,1,59,0)=" . S @(RANODE_""0)"")=""^^""_RATCNT_""^""_RATCNT_""^""_$S($D(DT)#2:DT,1:$$DT^XLFDT())"
1052^MAGD(2006.79,8,1,60,0)=" . Q"
1053^MAGD(2006.79,8,1,61,0)=" Q"
1054^MAGD(2006.79,9,0)="RAUTL5^3050311.125836"
1055^MAGD(2006.79,9,1,0)="^2006.791^135^135"
1056^MAGD(2006.79,9,1,1,0)="RAUTL5 ;HISC/CAH,FPT,GJC-Utility Routine ;3/12/98 13:27"
1057^MAGD(2006.79,9,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;**8,26**;Mar 16, 1998"
1058^MAGD(2006.79,9,1,3,0)="CH ; Populate the 'CLINICAL HISTORY' field (400) in file 74 (^RADPT)"
1059^MAGD(2006.79,9,1,4,0)=" ; Called from 'CREATE1^RAORD1'."
1060^MAGD(2006.79,9,1,5,0)=" N WPFLG"
1061^MAGD(2006.79,9,1,6,0)="CH1 I $D(RAVSTFLG),$D(RAVLEDTI),$D(RAVLECNI),$D(^RADPT(RADFN,""DT"",RAVLEDTI,""P"",RAVLECNI,""H"")) S:$D(^(""H"",0)) ^TMP($J,""RAWP"",0)=^(0) F RAI=1:1 Q:'$D(^RADPT(RADFN,""DT"",RAVLEDTI,""P"",RAVLECNI,""H"",RAI,0)) S ^TMP($J,""RAWP"",RAI,0)=^(0)"
1062^MAGD(2006.79,9,1,7,0)=" I $L($G(^RA(79,+RADIV,""HIS""))) W !!?3,*7,^(""HIS""),! K DIR S DIR(0)=""E"" D ^DIR I $D(DTOUT)!($D(DUOUT)) S RAOUT=1 Q"
1063^MAGD(2006.79,9,1,8,0)=" S DIC=""^TMP(""_$J_"",""""RAWP"""","",DWPK=1,DIWESUB=""Clin Hist/Reason"" W !,""CLINICAL HISTORY FOR EXAM"""
1064^MAGD(2006.79,9,1,9,0)=" D EN^DIWE K DIWESUB I '$O(^TMP($J,""RAWP"",0)) W !!,*7,""A clinical history corresponding to this request is required."",! D Q:$D(RAOUT) G CH1"
1065^MAGD(2006.79,9,1,10,0)=" .S DIR(0)=""Y"",DIR(""A"")=""Do you want to exit processing request"",DIR(""B"")=""Yes"" D ^DIR K DIR S:Y!($D(DIRUT)) RAOUT=1"
1066^MAGD(2006.79,9,1,11,0)=" K DIC S DIC=""^TMP(""_$J_"",""""RAWP"""","",DWPK=1"
1067^MAGD(2006.79,9,1,12,0)=" S WPFLG=$$VALWP(""^TMP(""_$J_"",""""RAWP"""","")"
1068^MAGD(2006.79,9,1,13,0)=" I 'WPFLG D Q:$D(RAOUT) G CH"
1069^MAGD(2006.79,9,1,14,0)=" . W !!,$C(7),""A clinical history corresponding to this request is required."",!"
1070^MAGD(2006.79,9,1,15,0)=" . K DIR S DIR(0)=""Y"",DIR(""B"")=""Yes"""
1071^MAGD(2006.79,9,1,16,0)=" . S DIR(""A"")=""Do you want to exit processing this request"""
1072^MAGD(2006.79,9,1,17,0)=" . S DIR(""?"")=""Enter 'Y' for yes, 'N' for no."" D ^DIR K DIR"
1073^MAGD(2006.79,9,1,18,0)=" . S:+Y!($D(DIRUT)) RAOUT=1 K DIROUT,DIRUT,DTOUT,DUOUT"
1074^MAGD(2006.79,9,1,19,0)=" . Q"
1075^MAGD(2006.79,9,1,20,0)="WPLEN ;Is clin hist too long to go into a local array for OE/RR HL7 msg?"
1076^MAGD(2006.79,9,1,21,0)=" S (CNT,X)=0 F S X=$O(^TMP($J,""RAWP"",X)) S CNT=CNT+1 Q:X'>0"
1077^MAGD(2006.79,9,1,22,0)=" I CNT>350 K CNT D Q:$D(RAOUT) G CH"
1078^MAGD(2006.79,9,1,23,0)=" . W !!,$C(7),""Clinical history cannot exceed 350 lines."""
1079^MAGD(2006.79,9,1,24,0)=" . K DIR S DIR(0)=""Y"",DIR(""B"")=""Yes"""
1080^MAGD(2006.79,9,1,25,0)=" . S DIR(""A"")=""Do you want to exit processing this request"""
1081^MAGD(2006.79,9,1,26,0)=" . S DIR(""?"")=""Enter 'Y' for yes, 'N' for no."" D ^DIR K DIR"
1082^MAGD(2006.79,9,1,27,0)=" . S:+Y!($D(DIRUT)) RAOUT=1 K DIROUT,DIRUT,DTOUT,DUOUT"
1083^MAGD(2006.79,9,1,28,0)=" . Q"
1084^MAGD(2006.79,9,1,29,0)=" K CNT Q"
1085^MAGD(2006.79,9,1,30,0)=" ;"
1086^MAGD(2006.79,9,1,31,0)="VALWP(RAROOT) ; Validate word processing field."
1087^MAGD(2006.79,9,1,32,0)=" ; Pass back '1' if data is valid, '0' if not valid."
1088^MAGD(2006.79,9,1,33,0)=" ; at least 2 alphanumeric char's required"
1089^MAGD(2006.79,9,1,34,0)=" Q:'$O(@(RAROOT_""0)"")) 0"
1090^MAGD(2006.79,9,1,35,0)=" N CHAR,CNT,WL,WPFLG,X,Y,Z"
1091^MAGD(2006.79,9,1,36,0)=" S (WPFLG,X)=0"
1092^MAGD(2006.79,9,1,37,0)=" F S X=$O(@(RAROOT_X_"")"")) Q:X'>0 D Q:WPFLG"
1093^MAGD(2006.79,9,1,38,0)=" . S (CNT,WL)=0"
1094^MAGD(2006.79,9,1,39,0)=" . S Y=$G(@(RAROOT_X_"",0)"")) Q:Y']"""""
1095^MAGD(2006.79,9,1,40,0)=" . S WL=$L(Y)"
1096^MAGD(2006.79,9,1,41,0)=" . F Z=1:1:WL D Q:WPFLG"
1097^MAGD(2006.79,9,1,42,0)=" .. S CHAR=$E(Y,Z) S:CHAR?1AN CNT=CNT+1"
1098^MAGD(2006.79,9,1,43,0)=" .. S:CHAR'?1AN&(CNT>0) CNT=0 S:CNT=2 WPFLG=1"
1099^MAGD(2006.79,9,1,44,0)=" .. Q"
1100^MAGD(2006.79,9,1,45,0)=" . Q"
1101^MAGD(2006.79,9,1,46,0)=" Q WPFLG"
1102^MAGD(2006.79,9,1,47,0)="RDQ(D0) ; Used by input transform on ^DD(74.31,2"
1103^MAGD(2006.79,9,1,48,0)=" ; Checks for unprinted reports associated with REPORT"
1104^MAGD(2006.79,9,1,49,0)=" ; DISTRIBUTION QUEUE of internal entry number of D0."
1105^MAGD(2006.79,9,1,50,0)=" N %,%Y,FOUND,RA744"
1106^MAGD(2006.79,9,1,51,0)=" S (FOUND,RA744)=0"
1107^MAGD(2006.79,9,1,52,0)=" F S RA744=$O(^RABTCH(74.4,""C"",D0,RA744)) Q:RA744'>0!FOUND D"
1108^MAGD(2006.79,9,1,53,0)=" . S FOUND=($P($G(^RABTCH(74.4,RA744,0)),""^"",4)'>0)"
1109^MAGD(2006.79,9,1,54,0)=" . Q"
1110^MAGD(2006.79,9,1,55,0)=" Q:'FOUND"
1111^MAGD(2006.79,9,1,56,0)=" W !!,""*** UNPRINTED REPORTS IN THE QUEUE ! ***"""
1112^MAGD(2006.79,9,1,57,0)=" W !,""If this queue is inactivated before printing, these reports will be"",!,""removed from the queue."""
1113^MAGD(2006.79,9,1,58,0)=" F D Q:%"
1114^MAGD(2006.79,9,1,59,0)=" . W !!,""Are you sure you want to remove these reports"""
1115^MAGD(2006.79,9,1,60,0)=" . S %=2 D YN^DICN"
1116^MAGD(2006.79,9,1,61,0)=" . I '% W !!?5,""Please answer Y(es) or N(o)."""
1117^MAGD(2006.79,9,1,62,0)=" . Q"
1118^MAGD(2006.79,9,1,63,0)=" I %'=1 W !,""Inactivation date deleted"" K X"
1119^MAGD(2006.79,9,1,64,0)=" Q"
1120^MAGD(2006.79,9,1,65,0)="ATND(RADFN,DATE) ;Returns the external form of the ATTENDING PHYSICIAN"
1121^MAGD(2006.79,9,1,66,0)=" ;for patient RADFN (IEN file #2) on date DATE (FM format)"
1122^MAGD(2006.79,9,1,67,0)=" N DPT,VA200,VAIP,X"
1123^MAGD(2006.79,9,1,68,0)=" S DFN=RADFN,VAIP(""D"")=DATE,VA200=1"
1124^MAGD(2006.79,9,1,69,0)=" I DATE D IN5^VADPT"
1125^MAGD(2006.79,9,1,70,0)=" S X=$P($G(VAIP(18)),""^"",2),X=$S(X]"""":X,1:""UNKNOWN"")"
1126^MAGD(2006.79,9,1,71,0)=" Q X"
1127^MAGD(2006.79,9,1,72,0)="PRIM(RADFN,DATE) ;Returns the external form of the PRIMARY PHYSICIAN"
1128^MAGD(2006.79,9,1,73,0)=" ;for patient RADFN (IEN file #2) on date DATE (FM format)"
1129^MAGD(2006.79,9,1,74,0)=" N DPT,VA200,VAIP,X"
1130^MAGD(2006.79,9,1,75,0)=" S DFN=RADFN,VAIP(""D"")=DATE,VA200=1"
1131^MAGD(2006.79,9,1,76,0)=" I DATE D IN5^VADPT"
1132^MAGD(2006.79,9,1,77,0)=" I '+$G(VAIP(7)) D"
1133^MAGD(2006.79,9,1,78,0)=" . ; If the Primary Physician is not found (based on inpatient episode)"
1134^MAGD(2006.79,9,1,79,0)=" . ; find the current PC Practitioner (See patch SD*5.3*30)"
1135^MAGD(2006.79,9,1,80,0)=" . ; VAIP(7) is null at this point. VAIP(7) will exit this DO block"
1136^MAGD(2006.79,9,1,81,0)=" . ; set to the Primary Care Practitioner or null."
1137^MAGD(2006.79,9,1,82,0)=" . N X S X=""SDUTL3"" X ^%ZOSF(""TEST"")"
1138^MAGD(2006.79,9,1,83,0)=" . S:$T VAIP(7)=$$OUTPTPR^SDUTL3(RADFN)"
1139^MAGD(2006.79,9,1,84,0)=" . Q"
1140^MAGD(2006.79,9,1,85,0)=" S X=$P($G(VAIP(7)),""^"",2),X=$S(X]"""":X,1:""UNKNOWN"")"
1141^MAGD(2006.79,9,1,86,0)=" Q X"
1142^MAGD(2006.79,9,1,87,0)="EOS() ; 'End Of Screen' prompt for terminals only, check user response."
1143^MAGD(2006.79,9,1,88,0)=" Q:$E(IOST,1,2)'=""C-"" 0"
1144^MAGD(2006.79,9,1,89,0)=" N RAY,X,X1,X2,X3,Y,Y0,Y1,Y2,Y3,Y4,Y5"
1145^MAGD(2006.79,9,1,90,0)=" ;Returns 1 if user enters anything other than a carriage return"
1146^MAGD(2006.79,9,1,91,0)=" K DIR S DIR(0)=""E"" D ^DIR K DIR,DIROUT,DIRUT,DTOUT,DUOUT"
1147^MAGD(2006.79,9,1,92,0)=" S RAY='+Y"
1148^MAGD(2006.79,9,1,93,0)=" Q RAY"
1149^MAGD(2006.79,9,1,94,0)="XTERNAL(Y,C) ; Change internal format to external format"
1150^MAGD(2006.79,9,1,95,0)=" ; 'Y' is the internal form of the data"
1151^MAGD(2006.79,9,1,96,0)=" ; 'C' defines the data type of the variable 'Y'"
1152^MAGD(2006.79,9,1,97,0)=" D:Y]"""" Y^DIQ"
1153^MAGD(2006.79,9,1,98,0)=" Q Y"
1154^MAGD(2006.79,9,1,99,0)="PROCMSG(RAPRI) ; Print the appropriate procedure messages. Called from"
1155^MAGD(2006.79,9,1,100,0)=" ; DESDT^RAUTL12. This code works under the assumption that the"
1156^MAGD(2006.79,9,1,101,0)=" ; user has entered through OE/RR."
1157^MAGD(2006.79,9,1,102,0)=" ;ATTENTION: this code must be parallet to code in EN2^RAPRI"
1158^MAGD(2006.79,9,1,103,0)=" Q:+$G(RASTOP) ; Do not display if displayed in the past."
1159^MAGD(2006.79,9,1,104,0)=" I $O(^RAMIS(71,RAPRI,3,0)) D S RASTOP=1"
1160^MAGD(2006.79,9,1,105,0)=" . N I,RAX,X S I=0"
1161^MAGD(2006.79,9,1,106,0)=" . W !!?5,""NOTE: The following special requirements apply to this """
1162^MAGD(2006.79,9,1,107,0)=" . W ""procedure:"",$C(7),!"
1163^MAGD(2006.79,9,1,108,0)=" . F S I=+$O(^RAMIS(71,RAPRI,3,I)) Q:'I D"
1164^MAGD(2006.79,9,1,109,0)=" .. S RAX=+$G(^RAMIS(71,RAPRI,3,I,0))"
1165^MAGD(2006.79,9,1,110,0)=" .. I $D(^RAMIS(71.4,+RAX,0)) D"
1166^MAGD(2006.79,9,1,111,0)=" ... I $Y>(IOSL-6) D READ^ORUTL W @IOF"
1167^MAGD(2006.79,9,1,112,0)=" ... S X=$G(^RAMIS(71.4,+RAX,0)) W !?3,X"
1168^MAGD(2006.79,9,1,113,0)=" ... Q"
1169^MAGD(2006.79,9,1,114,0)=" .. Q"
1170^MAGD(2006.79,9,1,115,0)=" . Q"
1171^MAGD(2006.79,9,1,116,0)=" I $O(^RAMIS(71,RAPRI,""EDU"",0)),($$UP^XLFSTR($P($G(^RAMIS(71,RAPRI,0)),""^"",17))=""Y"") D"
1172^MAGD(2006.79,9,1,117,0)=" . W:+$O(^RAMIS(71,+RAPRI,3,0))>0 !!"
1173^MAGD(2006.79,9,1,118,0)=" . N DIW,DIWF,DIWL,DIWR,RAX,X"
1174^MAGD(2006.79,9,1,119,0)=" . K ^UTILITY($J,""W"") S DIWF=""W"",DIWL=1,DIWR=75,RAX=0"
1175^MAGD(2006.79,9,1,120,0)=" . F S RAX=$O(^RAMIS(71,RAPRI,""EDU"",RAX)) Q:RAX'>0 D"
1176^MAGD(2006.79,9,1,121,0)=" .. I $Y>(IOSL-4) D READ^ORUTL W @IOF"
1177^MAGD(2006.79,9,1,122,0)=" .. S X=$G(^RAMIS(71,RAPRI,""EDU"",RAX,0)) D ^DIWP"
1178^MAGD(2006.79,9,1,123,0)=" .. Q"
1179^MAGD(2006.79,9,1,124,0)=" . I $Y>(IOSL-4) D READ^ORUTL W @IOF"
1180^MAGD(2006.79,9,1,125,0)=" . D ^DIWW"
1181^MAGD(2006.79,9,1,126,0)=" . W !"
1182^MAGD(2006.79,9,1,127,0)=" . Q"
1183^MAGD(2006.79,9,1,128,0)=" Q"
1184^MAGD(2006.79,9,1,129,0)="MIDNGHT(X) ; Check if the date passed in is midnight. If it is, add one"
1185^MAGD(2006.79,9,1,130,0)=" ; minute to the date/time. Fixes infinite loop problem in FM when"
1186^MAGD(2006.79,9,1,131,0)=" ; midnight."
1187^MAGD(2006.79,9,1,132,0)=" ; Input: X-Current system date/time (derived from $$NOW^XLFDT)"
1188^MAGD(2006.79,9,1,133,0)=" S:X[""."" X=$E(X,1,($F(X,""."")+3)) ; chop off seconds IF there's decimal"
1189^MAGD(2006.79,9,1,134,0)=" S:+$P(X,""."",2)=24!(+$P(X,""."",2)=0) X=$$FMADD^XLFDT(X,0,0,1,0) ; add a minute to midnight"
1190^MAGD(2006.79,9,1,135,0)=" Q X"
1191^MAGD(2006.79,10,0)="RAXREF^3050311.125837"
1192^MAGD(2006.79,10,1,0)="^2006.791^27^27"
1193^MAGD(2006.79,10,1,1,0)="RAXREF ;HISC/DAD-EXECUTE SET AND KILL XREF'S ;8/22/96 15:02"
1194^MAGD(2006.79,10,1,2,0)=" ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998"
1195^MAGD(2006.79,10,1,3,0)=" ; REQUIRED VARIABLES"
1196^MAGD(2006.79,10,1,4,0)=" ; RADICT = DATA DICTIONARY NUMBER"
1197^MAGD(2006.79,10,1,5,0)=" ; RAFLD = FIELD NUMBER IN THE ABOVE DD"
1198^MAGD(2006.79,10,1,6,0)=" ; RAX = FIELD VALUE TO BE CROSS REFERENCED"
1199^MAGD(2006.79,10,1,7,0)=" ; DA = DA or DA array"
1200^MAGD(2006.79,10,1,8,0)="ENKILL(RADICT,RAFLD,RAX,DA) ;"
1201^MAGD(2006.79,10,1,9,0)=" ; *** Execute a field's cross reference kill logic"
1202^MAGD(2006.79,10,1,10,0)=" D CHECK I RAEXIT D EXIT Q"
1203^MAGD(2006.79,10,1,11,0)=" S RAXSAV=RAX"
1204^MAGD(2006.79,10,1,12,0)=" F RAXREF=0:0 S RAXREF=$O(^DD(RADICT,RAFLD,1,RAXREF)) Q:RAXREF'>0 S X=RAXSAV X:$D(^DD(RADICT,RAFLD,1,RAXREF,2))#2 ^(2)"
1205^MAGD(2006.79,10,1,13,0)=" D EXIT"
1206^MAGD(2006.79,10,1,14,0)=" Q"
1207^MAGD(2006.79,10,1,15,0)="ENSET(RADICT,RAFLD,RAX,DA) ;"
1208^MAGD(2006.79,10,1,16,0)=" ; *** Execute a field's cross reference set logic"
1209^MAGD(2006.79,10,1,17,0)=" D CHECK I RAEXIT D EXIT Q"
1210^MAGD(2006.79,10,1,18,0)=" S RAXSAV=RAX"
1211^MAGD(2006.79,10,1,19,0)=" F RAXREF=0:0 S RAXREF=$O(^DD(RADICT,RAFLD,1,RAXREF)) Q:RAXREF'>0 S X=RAXSAV X:$D(^DD(RADICT,RAFLD,1,RAXREF,1))#2 ^(1)"
1212^MAGD(2006.79,10,1,20,0)=" D EXIT"
1213^MAGD(2006.79,10,1,21,0)=" Q"
1214^MAGD(2006.79,10,1,22,0)="EXIT ; Kill and quit"
1215^MAGD(2006.79,10,1,23,0)=" K RAEXIT,RAXREF,RAXSAV"
1216^MAGD(2006.79,10,1,24,0)=" Q"
1217^MAGD(2006.79,10,1,25,0)="CHECK ; Check if parameters are valid"
1218^MAGD(2006.79,10,1,26,0)=" S RAEXIT=$S($D(DA)[0:1,$D(RAX)[0:1,$D(RADICT)[0:1,$D(RAFLD)[0:1,RAX="""":1,RADICT'>0:1,RAFLD'>0:1,1:0)"
1219^MAGD(2006.79,10,1,27,0)=" Q"
1220^MAGD(2006.79,11,0)="TIULC1^3050311.125837"
1221^MAGD(2006.79,11,1,0)="^2006.791^217^217"
1222^MAGD(2006.79,11,1,1,0)="TIULC1 ; SLC/JER - More computational functions ;11/01/03"
1223^MAGD(2006.79,11,1,2,0)=" ;;1.0;TEXT INTEGRATION UTILITIES;**3,4,40,49,100,131,113,112**;Jun 20, 1997"
1224^MAGD(2006.79,11,1,3,0)=" ; External References"
1225^MAGD(2006.79,11,1,4,0)=" ; DBIA 2324 $$ISA^USRLM"
1226^MAGD(2006.79,11,1,5,0)=" ; Any patch which makes ANY changes to this rtn must include a"
1227^MAGD(2006.79,11,1,6,0)=" ;note in the patch desc reminding sites to update the Imaging"
1228^MAGD(2006.79,11,1,7,0)=" ;Gateway. See IA # 3622."
1229^MAGD(2006.79,11,1,8,0)=" ; IN ADDITION, if changes are made to components used by Imaging, "
1230^MAGD(2006.79,11,1,9,0)=" ;namely PNAME, backward compatibility may not be enough. If"
1231^MAGD(2006.79,11,1,10,0)=" ;changes call additional rtns, TIU should consult with Imaging"
1232^MAGD(2006.79,11,1,11,0)=" ;on need to add additional rtns to list of TIU rtns copied for"
1233^MAGD(2006.79,11,1,12,0)=" ;Imaging Gateway."
1234^MAGD(2006.79,11,1,13,0)=" ; ****"
1235^MAGD(2006.79,11,1,14,0)=" ;"
1236^MAGD(2006.79,11,1,15,0)="ENCRYPT(X,X1,X2) ; Encrypt Text Strings"
1237^MAGD(2006.79,11,1,16,0)=" D EN^XUSHSHP"
1238^MAGD(2006.79,11,1,17,0)=" Q X"
1239^MAGD(2006.79,11,1,18,0)="DECRYPT(X,X1,X2) ; Decrypt Text Strings"
1240^MAGD(2006.79,11,1,19,0)=" D DE^XUSHSHP"
1241^MAGD(2006.79,11,1,20,0)=" Q X"
1242^MAGD(2006.79,11,1,21,0)="WHOSIGNS(DA) ; Evaluate who should be the expected signer"
1243^MAGD(2006.79,11,1,22,0)=" N Y,TIU12"
1244^MAGD(2006.79,11,1,23,0)=" S TIU12=$G(^TIU(8925,+DA,12))"
1245^MAGD(2006.79,11,1,24,0)=" I $P(TIU12,U,2)'=$P(TIU12,U,9) S Y=$P(TIU12,U,2)"
1246^MAGD(2006.79,11,1,25,0)=" E S Y=$P(TIU12,U,9)"
1247^MAGD(2006.79,11,1,26,0)=" Q Y"
1248^MAGD(2006.79,11,1,27,0)="WHOCOSIG(DA) ; Evaluate who should be the expected cosigner"
1249^MAGD(2006.79,11,1,28,0)=" N Y,TIU12"
1250^MAGD(2006.79,11,1,29,0)=" S TIU12=$G(^TIU(8925,+DA,12))"
1251^MAGD(2006.79,11,1,30,0)=" I $P(TIU12,U,2)=$P(TIU12,U,9) D"
1252^MAGD(2006.79,11,1,31,0)=" . I $P(TIU12,U,8)]"""" S Y=""@"""
1253^MAGD(2006.79,11,1,32,0)=" . E S Y="""""
1254^MAGD(2006.79,11,1,33,0)=" E S Y=$P(TIU12,U,9)"
1255^MAGD(2006.79,11,1,34,0)=" Q Y"
1256^MAGD(2006.79,11,1,35,0)=" ;"
1257^MAGD(2006.79,11,1,36,0)="HASADDEN(DA,IDKIDFLG) ; Evaluate whether a given record has addenda"
1258^MAGD(2006.79,11,1,37,0)=" ; **100**:"
1259^MAGD(2006.79,11,1,38,0)=" ; If +IDKIDFLG, check interdisciplinary kids of DA, as well as DA."
1260^MAGD(2006.79,11,1,39,0)=" N TIUI,TIUY,TIUJ,TIUK"
1261^MAGD(2006.79,11,1,40,0)=" S (TIUI,TIUJ,TIUY)=0"
1262^MAGD(2006.79,11,1,41,0)=" F S TIUI=$O(^TIU(8925,""DAD"",+DA,TIUI)) Q:+TIUI'>0 D Q:TIUY"
1263^MAGD(2006.79,11,1,42,0)=" . I $P($G(^TIU(8925.1,+$G(^TIU(8925,+TIUI,0)),0)),U)[""ADDENDUM"" S TIUY=1"
1264^MAGD(2006.79,11,1,43,0)=" I TIUY!'$G(IDKIDFLG) G HASX"
1265^MAGD(2006.79,11,1,44,0)=" ;**100** Check ID kids for addenda:"
1266^MAGD(2006.79,11,1,45,0)=" F S TIUJ=$O(^TIU(8925,""GDAD"",+DA,TIUJ)) Q:+TIUJ'>0 D Q:TIUY"
1267^MAGD(2006.79,11,1,46,0)=" . S TIUK=0"
1268^MAGD(2006.79,11,1,47,0)=" . F S TIUK=$O(^TIU(8925,""DAD"",TIUJ,TIUK)) Q:+TIUK'>0 D Q:TIUY"
1269^MAGD(2006.79,11,1,48,0)=" . . I $P($G(^TIU(8925.1,+$G(^TIU(8925,+TIUK,0)),0)),U)[""ADDENDUM"" S TIUY=1"
1270^MAGD(2006.79,11,1,49,0)="HASX Q TIUY"
1271^MAGD(2006.79,11,1,50,0)=" ;"
1272^MAGD(2006.79,11,1,51,0)="ISADDNDM(DA) ; Evaluate whether a given record IS an addendum"
1273^MAGD(2006.79,11,1,52,0)=" N TIUY S TIUY=0"
1274^MAGD(2006.79,11,1,53,0)=" I $P($G(^TIU(8925.1,+$G(^TIU(8925,+DA,0)),0)),U)[""ADDENDUM"",+$P($G(^TIU(8925,+DA,0)),U,6)>0 S TIUY=1"
1275^MAGD(2006.79,11,1,54,0)=" Q TIUY"
1276^MAGD(2006.79,11,1,55,0)="PNAME(DA) ; Receives pointer to 8925.1, returns display name of"
1277^MAGD(2006.79,11,1,56,0)=" ; document class"
1278^MAGD(2006.79,11,1,57,0)=" N TIUY,TIUMOM S TIUMOM=0"
1279^MAGD(2006.79,11,1,58,0)=" I +$G(DA)'>0 Q ""UNKNOWN"""
1280^MAGD(2006.79,11,1,59,0)=" S TIUMOM=$O(^TIU(8925.1,""AD"",DA,TIUMOM))"
1281^MAGD(2006.79,11,1,60,0)=" I $P($G(^TIU(8925.1,+DA,0)),U,4)=""CO"" S TIUMOM=0"
1282^MAGD(2006.79,11,1,61,0)=" I +$P($G(^TIU(8925.1,+DA,0)),U,9)=0 S TIUMOM=0"
1283^MAGD(2006.79,11,1,62,0)=" I +TIUMOM>0 D"
1284^MAGD(2006.79,11,1,63,0)=" . S TIUY=$P($G(^TIU(8925.1,+TIUMOM,0)),U,3)"
1285^MAGD(2006.79,11,1,64,0)=" . I TIUY']"""" S TIUY=$$MIXED^TIULS($P($G(^TIU(8925.1,+TIUMOM,0)),U))"
1286^MAGD(2006.79,11,1,65,0)=" I +TIUMOM'>0 D"
1287^MAGD(2006.79,11,1,66,0)=" . S TIUY=$P($G(^TIU(8925.1,+DA,0)),U,3)"
1288^MAGD(2006.79,11,1,67,0)=" . I TIUY']"""" S TIUY=$$MIXED^TIULS($P($G(^TIU(8925.1,+DA,0)),U))"
1289^MAGD(2006.79,11,1,68,0)=" Q TIUY"
1290^MAGD(2006.79,11,1,69,0)="ABBREV(DA) ; Get abbreviaton for a document type or class"
1291^MAGD(2006.79,11,1,70,0)=" Q $P($G(^TIU(8925.1,+DA,0)),U,2)"
1292^MAGD(2006.79,11,1,71,0)="PERSNAME(USER) ; Receives pointer to 200, returns name field"
1293^MAGD(2006.79,11,1,72,0)=" N X S X=$$GET1^DIQ(200,USER,.01)"
1294^MAGD(2006.79,11,1,73,0)=" Q $S($L(X):X,1:""UNKNOWN"")"
1295^MAGD(2006.79,11,1,74,0)="BEEP(USER) ; Get beeper #'s "
1296^MAGD(2006.79,11,1,75,0)=" Q $P($G(^VA(200,+USER,.13)),U,7,8)"
1297^MAGD(2006.79,11,1,76,0)="DOCPRM(TIUTYP,TIUDPRM,TIUDA) ; Get Document Parameters, support inheritance"
1298^MAGD(2006.79,11,1,77,0)=" N TIUI,TIUDAD"
1299^MAGD(2006.79,11,1,78,0)=" S (TIUDPRM(0),TIUDPRM(5))="""""
1300^MAGD(2006.79,11,1,79,0)=" I $P($G(^TIU(8925.1,+TIUTYP,0)),U)[""ADDENDUM"",+$G(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))"
1301^MAGD(2006.79,11,1,80,0)=" S TIUI=+$O(^TIU(8925.95,""B"",+TIUTYP,0))"
1302^MAGD(2006.79,11,1,81,0)=" I +TIUI D Q"
1303^MAGD(2006.79,11,1,82,0)=" . S TIUDPRM(0)=$G(^TIU(8925.95,+TIUI,0))"
1304^MAGD(2006.79,11,1,83,0)=" . I +$O(^TIU(8925.95,+TIUI,5,0)) D"
1305^MAGD(2006.79,11,1,84,0)=" . . N TIUJ S TIUJ=0"
1306^MAGD(2006.79,11,1,85,0)=" . . F S TIUJ=$O(^TIU(8925.95,+TIUI,5,TIUJ)) Q:+TIUJ'>0 D"
1307^MAGD(2006.79,11,1,86,0)=" . . . S $P(TIUDPRM(5),U,TIUJ)=+$G(^TIU(8925.95,+TIUI,5,+TIUJ,0))"
1308^MAGD(2006.79,11,1,87,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1309^MAGD(2006.79,11,1,88,0)=" I +TIUDAD D DOCPRM(TIUDAD,.TIUDPRM)"
1310^MAGD(2006.79,11,1,89,0)=" Q"
1311^MAGD(2006.79,11,1,90,0)="POSTFILE(TIUTYP) ; Get Post-filing Code, support inheritance"
1312^MAGD(2006.79,11,1,91,0)=" N TIUPOST,TIUDAD"
1313^MAGD(2006.79,11,1,92,0)=" S TIUPOST=$G(^TIU(8925.1,+TIUTYP,4.5))"
1314^MAGD(2006.79,11,1,93,0)=" I TIUPOST]"""" G POSTFILX"
1315^MAGD(2006.79,11,1,94,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1316^MAGD(2006.79,11,1,95,0)=" I +TIUDAD S TIUPOST=$$POSTFILE(TIUDAD)"
1317^MAGD(2006.79,11,1,96,0)="POSTFILX Q TIUPOST"
1318^MAGD(2006.79,11,1,97,0)="FIXCODE(TIUTYP) ; Get Error Resolution Code, support inheritance"
1319^MAGD(2006.79,11,1,98,0)=" N TIUFIX,TIUDAD"
1320^MAGD(2006.79,11,1,99,0)=" S TIUFIX=$G(^TIU(8925.1,+TIUTYP,4.8))"
1321^MAGD(2006.79,11,1,100,0)=" I TIUFIX]"""" G FIXCODX"
1322^MAGD(2006.79,11,1,101,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1323^MAGD(2006.79,11,1,102,0)=" ; Don't inherit PN code for consults: TIU*1*131"
1324^MAGD(2006.79,11,1,103,0)=" I +TIUTYP=$$CLASS^TIUCNSLT,TIUDAD=3 G FIXCODX"
1325^MAGD(2006.79,11,1,104,0)=" I +TIUDAD S TIUFIX=$$FIXCODE(TIUDAD)"
1326^MAGD(2006.79,11,1,105,0)="FIXCODX Q TIUFIX"
1327^MAGD(2006.79,11,1,106,0)="DOCCLASS(TIUTYP) ; Given a document type, find its parent document class"
1328^MAGD(2006.79,11,1,107,0)=" Q +$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1329^MAGD(2006.79,11,1,108,0)="CLINDOC(TIUTYP,TIUDA) ; Given a document type, find the Clinical Document"
1330^MAGD(2006.79,11,1,109,0)=" ; subclass to which it belongs"
1331^MAGD(2006.79,11,1,110,0)=" N TIUI,TIUY S (TIUI,TIUY)=0"
1332^MAGD(2006.79,11,1,111,0)=" I +$G(TIUDA),+$$ISADDNDM(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))"
1333^MAGD(2006.79,11,1,112,0)=" S TIUI=$O(^TIU(8925.1,""AD"",+TIUTYP,TIUI))"
1334^MAGD(2006.79,11,1,113,0)=" I +TIUI'>0 G CLINDOX"
1335^MAGD(2006.79,11,1,114,0)=" I TIUI=38 S TIUY=TIUTYP"
1336^MAGD(2006.79,11,1,115,0)=" I TIUI'=38 S TIUY=$$CLINDOC(TIUI)"
1337^MAGD(2006.79,11,1,116,0)="CLINDOX Q TIUY"
1338^MAGD(2006.79,11,1,117,0)="REQVER(TIUTYP,TIUDA) ; Does a given document type require verification"
1339^MAGD(2006.79,11,1,118,0)=" N TIUDPRM,TIUY"
1340^MAGD(2006.79,11,1,119,0)=" I +$G(TIUDA),+$$ISADDNDM(TIUDA) S TIUTYP=+$G(^TIU(8925,+$P($G(^TIU(8925,+TIUDA,0)),U,6),0))"
1341^MAGD(2006.79,11,1,120,0)=" D DOCPRM(TIUTYP,.TIUDPRM)"
1342^MAGD(2006.79,11,1,121,0)=" I +$P($G(TIUDPRM(0)),U,3) S TIUY=1"
1343^MAGD(2006.79,11,1,122,0)=" Q +$G(TIUY)"
1344^MAGD(2006.79,11,1,123,0)="REFDATE(TIU,TIUDICDT) ; Identify Reference date"
1345^MAGD(2006.79,11,1,124,0)=" N TIURDT"
1346^MAGD(2006.79,11,1,125,0)=" I +$G(TIU(""LDT"")) S TIURDT=+$G(TIU(""LDT""))_""^0"""
1347^MAGD(2006.79,11,1,126,0)=" I +$G(TIU(""LDT""))'>0 D"
1348^MAGD(2006.79,11,1,127,0)=" . S TIURDT=$S(+$G(TIUDICDT):+$G(TIUDICDT),1:+$$NOW^TIULC)_""^1"""
1349^MAGD(2006.79,11,1,128,0)=" . S TIU(""LDT"")=TIURDT_U_$$DATE^TIULS(TIURDT,""AMTH DD, CCYY@HR:MIN:SEC"")"
1350^MAGD(2006.79,11,1,129,0)=" Q TIURDT"
1351^MAGD(2006.79,11,1,130,0)="WHATMPL(USER) ; What List Template should a given user get?"
1352^MAGD(2006.79,11,1,131,0)=" N TIUY"
1353^MAGD(2006.79,11,1,132,0)=" I +$$ISA^USRLM(USER,""PROVIDER"") S TIUY=""TIU BROWSE FOR CLINICIAN"" G WHAX"
1354^MAGD(2006.79,11,1,133,0)=" I +$$ISA^USRLM(USER,""MEDICAL RECORDS TECHNICIAN"") S TIUY=""TIU BROWSE FOR MRT"" G WHAX"
1355^MAGD(2006.79,11,1,134,0)=" I +$$ISA^USRLM(USER,""CHIEF, MIS"") S TIUY=""TIU BROWSE FOR MGR"" G WHAX"
1356^MAGD(2006.79,11,1,135,0)=" I +$$ISA^USRLM(USER,""MEDICAL STUDENT"") S TIUY=""TIU BROWSE FOR CLINICIAN"" G WHAX"
1357^MAGD(2006.79,11,1,136,0)=" S TIUY=""TIU BROWSE FOR READ ONLY"""
1358^MAGD(2006.79,11,1,137,0)="WHAX Q TIUY"
1359^MAGD(2006.79,11,1,138,0)="SUPPVSIT(TIUTYP) ; Evaluate whether to suppress visit matching"
1360^MAGD(2006.79,11,1,139,0)=" N TIUI,TIUY S TIUY=0"
1361^MAGD(2006.79,11,1,140,0)=" I +$P($G(^TIU(8925.1,+TIUTYP,3)),U,3) S TIUY=1 G SUPPVSIX"
1362^MAGD(2006.79,11,1,141,0)=" I $L($P($G(^TIU(8925.1,+TIUTYP,3)),U,3)),($P($G(^(3)),U,3)=0) S TIUY=0 G SUPPVSIX ; ** SLC/JER - NOIS NYC-1298-11472"
1363^MAGD(2006.79,11,1,142,0)=" S TIUI=0 F S TIUI=$O(^TIU(8925.1,""AD"",+TIUTYP,TIUI)) Q:+TIUI'>0!(+TIUY>0) D"
1364^MAGD(2006.79,11,1,143,0)=" . S TIUY=+$$SUPPVSIT(+TIUI)"
1365^MAGD(2006.79,11,1,144,0)="SUPPVSIX Q TIUY"
1366^MAGD(2006.79,11,1,145,0)="PTNAME(DFN) ; Resolve Patient Name"
1367^MAGD(2006.79,11,1,146,0)=" N TIUY S TIUY=$P($G(^DPT(DFN,0)),U)"
1368^MAGD(2006.79,11,1,147,0)=" S:TIUY']"""" TIUY=""NAME UNKNOWN"""
1369^MAGD(2006.79,11,1,148,0)=" Q TIUY"
1370^MAGD(2006.79,11,1,149,0)="POSTSIGN(TIUTYP) ; Get Post-Signature Code, support inheritance"
1371^MAGD(2006.79,11,1,150,0)=" N TIUPOST,TIUDAD"
1372^MAGD(2006.79,11,1,151,0)=" S TIUPOST=$G(^TIU(8925.1,+TIUTYP,4.9))"
1373^MAGD(2006.79,11,1,152,0)=" I TIUPOST]"""" G POSTSIGX"
1374^MAGD(2006.79,11,1,153,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1375^MAGD(2006.79,11,1,154,0)=" I +TIUDAD S TIUPOST=$$POSTSIGN(TIUDAD)"
1376^MAGD(2006.79,11,1,155,0)="POSTSIGX Q TIUPOST"
1377^MAGD(2006.79,11,1,156,0)="COMMIT(TIUTYP) ; Get Commitment action, support inheritance"
1378^MAGD(2006.79,11,1,157,0)=" N TIUCOMM,TIUDAD"
1379^MAGD(2006.79,11,1,158,0)=" S TIUCOMM=$G(^TIU(8925.1,+TIUTYP,4.1))"
1380^MAGD(2006.79,11,1,159,0)=" I TIUCOMM]"""" G COMMITX"
1381^MAGD(2006.79,11,1,160,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1382^MAGD(2006.79,11,1,161,0)=" I +TIUDAD S TIUCOMM=$$COMMIT(TIUDAD)"
1383^MAGD(2006.79,11,1,162,0)="COMMITX Q TIUCOMM"
1384^MAGD(2006.79,11,1,163,0)="RELEASE(TIUTYP) ; Get Release Action, support inheritance"
1385^MAGD(2006.79,11,1,164,0)=" N TIUREL,TIUDAD"
1386^MAGD(2006.79,11,1,165,0)=" S TIUREL=$G(^TIU(8925.1,+TIUTYP,4.2))"
1387^MAGD(2006.79,11,1,166,0)=" I TIUREL]"""" G RELEASX"
1388^MAGD(2006.79,11,1,167,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1389^MAGD(2006.79,11,1,168,0)=" I +TIUDAD S TIUREL=$$RELEASE(TIUDAD)"
1390^MAGD(2006.79,11,1,169,0)="RELEASX Q TIUREL"
1391^MAGD(2006.79,11,1,170,0)="VERIFY(TIUTYP) ; Get Verification action, support inheritance"
1392^MAGD(2006.79,11,1,171,0)=" N TIUVER,TIUDAD"
1393^MAGD(2006.79,11,1,172,0)=" S TIUVER=$G(^TIU(8925.1,+TIUTYP,4.3))"
1394^MAGD(2006.79,11,1,173,0)=" I TIUVER]"""" G VERIFYX"
1395^MAGD(2006.79,11,1,174,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1396^MAGD(2006.79,11,1,175,0)=" I +TIUDAD S TIUVER=$$VERIFY(TIUDAD)"
1397^MAGD(2006.79,11,1,176,0)="VERIFYX Q TIUVER"
1398^MAGD(2006.79,11,1,177,0)="DELETE(TIUTYP) ; Get Delete Action, support inheritance"
1399^MAGD(2006.79,11,1,178,0)=" N TIUDEL,TIUDAD"
1400^MAGD(2006.79,11,1,179,0)=" S TIUDEL=$G(^TIU(8925.1,+TIUTYP,4.4))"
1401^MAGD(2006.79,11,1,180,0)=" I TIUDEL]"""" G DELETEX"
1402^MAGD(2006.79,11,1,181,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1403^MAGD(2006.79,11,1,182,0)=" I +TIUDAD S TIUDEL=$$DELETE(TIUDAD)"
1404^MAGD(2006.79,11,1,183,0)="DELETEX Q TIUDEL"
1405^MAGD(2006.79,11,1,184,0)="REASSIGN(TIUTYP) ; Get Package Reassign Action, support inheritance"
1406^MAGD(2006.79,11,1,185,0)=" N TIUREASS,TIUDAD"
1407^MAGD(2006.79,11,1,186,0)=" S TIUREASS=$G(^TIU(8925.1,+TIUTYP,4.45))"
1408^MAGD(2006.79,11,1,187,0)=" I TIUREASS]"""" G REASSIX"
1409^MAGD(2006.79,11,1,188,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1410^MAGD(2006.79,11,1,189,0)=" I +TIUDAD S TIUREASS=$$REASSIGN(TIUDAD)"
1411^MAGD(2006.79,11,1,190,0)="REASSIX Q TIUREASS"
1412^MAGD(2006.79,11,1,191,0)="ONBROWSE(TIUTYP) ; Get OnBrowse Event, support inheritance"
1413^MAGD(2006.79,11,1,192,0)=" N TIUBRWS,TIUDAD"
1414^MAGD(2006.79,11,1,193,0)=" S TIUBRWS=$G(^TIU(8925.1,+TIUTYP,6.5))"
1415^MAGD(2006.79,11,1,194,0)=" I TIUBRWS]"""" G ONBRWSX"
1416^MAGD(2006.79,11,1,195,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1417^MAGD(2006.79,11,1,196,0)=" I +TIUDAD S TIUBRWS=$$ONBROWSE(TIUDAD)"
1418^MAGD(2006.79,11,1,197,0)="ONBRWSX Q TIUBRWS"
1419^MAGD(2006.79,11,1,198,0)="ONRTRCT(TIUTYP) ; Get OnRetract Event, support inheritance"
1420^MAGD(2006.79,11,1,199,0)=" N TIURTRCT,TIUDAD"
1421^MAGD(2006.79,11,1,200,0)=" S TIURTRCT=$G(^TIU(8925.1,+TIUTYP,6.51))"
1422^MAGD(2006.79,11,1,201,0)=" I TIURTRCT]"""" G ONRTRX"
1423^MAGD(2006.79,11,1,202,0)=" S TIUDAD=$O(^TIU(8925.1,""AD"",+TIUTYP,0))"
1424^MAGD(2006.79,11,1,203,0)=" I +TIUDAD S TIURTRCT=$$ONRTRCT(TIUDAD)"
1425^MAGD(2006.79,11,1,204,0)="ONRTRX Q TIURTRCT"
1426^MAGD(2006.79,11,1,205,0)="DIVISION(TIULOC) ; Get Division"
1427^MAGD(2006.79,11,1,206,0)=" ; Input -- TIULOC HOSPITAL LOCATION file (#44) IEN"
1428^MAGD(2006.79,11,1,207,0)=" ; Output -- TIUIN INSTITUTION file (#4) IEN^"
1429^MAGD(2006.79,11,1,208,0)=" ; INSTITUTION file (#4) NAME"
1430^MAGD(2006.79,11,1,209,0)=" N TIUDVHL,TIUSTN,TIUIN"
1431^MAGD(2006.79,11,1,210,0)=" S TIUDVHL=$P($G(^SC(+TIULOC,0)),U,15)"
1432^MAGD(2006.79,11,1,211,0)=" I +TIUDVHL D"
1433^MAGD(2006.79,11,1,212,0)=" . S TIUSTN=$$SITE^VASITE(,TIUDVHL)"
1434^MAGD(2006.79,11,1,213,0)=" . I $P(TIUSTN,U)>0,($P(TIUSTN,U,2)]"""") D"
1435^MAGD(2006.79,11,1,214,0)=" . . S TIUIN=$P(TIUSTN,U)_U_$P(TIUSTN,U,2)"
1436^MAGD(2006.79,11,1,215,0)=" I '$G(TIUIN) D"
1437^MAGD(2006.79,11,1,216,0)=" . S TIUIN=+$G(DUZ(2))_U_$P($$NS^XUAF4(+$G(DUZ(2))),U)"
1438^MAGD(2006.79,11,1,217,0)=" Q TIUIN"
1439^MAGD(2006.79,12,0)="TIULS^3050311.125837"
1440^MAGD(2006.79,12,1,0)="^2006.791^104^104"
1441^MAGD(2006.79,12,1,1,0)="TIULS ; SLC/JER - String Library functions ;10/7/94 17:18 [1/5/04 11:29am]"
1442^MAGD(2006.79,12,1,2,0)=" ;;1.0;TEXT INTEGRATION UTILITIES;**178**;Jun 20, 1997"
1443^MAGD(2006.79,12,1,3,0)=" ;"
1444^MAGD(2006.79,12,1,4,0)=" ; **** WARNING ****"
1445^MAGD(2006.79,12,1,5,0)=" ;"
1446^MAGD(2006.79,12,1,6,0)=" ; Any patch which makes ANY changes to this rtn must include a"
1447^MAGD(2006.79,12,1,7,0)=" ;note in the patch desc reminding sites to update the Imaging"
1448^MAGD(2006.79,12,1,8,0)=" ;Gateway. See IA # 3622."
1449^MAGD(2006.79,12,1,9,0)=" ; IN ADDITION, if changes are made to components used by Imaging,"
1450^MAGD(2006.79,12,1,10,0)=" ;namely, MIXED, backward compatibility may not be enough. If"
1451^MAGD(2006.79,12,1,11,0)=" ;changes call additional rtns, TIU should consult with Imaging"
1452^MAGD(2006.79,12,1,12,0)=" ;on need to add additional rtns to list of TIU rtns copied for"
1453^MAGD(2006.79,12,1,13,0)=" ;Imaging Gateway."
1454^MAGD(2006.79,12,1,14,0)=" ; ****"
1455^MAGD(2006.79,12,1,15,0)=" ;"
1456^MAGD(2006.79,12,1,16,0)="TIME(X,FMT) ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS)."
1457^MAGD(2006.79,12,1,17,0)=" N HR,MIN,SEC,TIUI"
1458^MAGD(2006.79,12,1,18,0)=" I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT=""HR:MIN"""
1459^MAGD(2006.79,12,1,19,0)=" S X=$P(X,""."",2),HR=$E(X,1,2)_$E(""00"",0,2-$L($E(X,1,2))),MIN=$E(X,3,4)_$E(""00"",0,2-$L($E(X,3,4))),SEC=$E(X,5,6)_$E(""00"",0,2-$L($E(X,5,6)))"
1460^MAGD(2006.79,12,1,20,0)=" F TIUI=""HR"",""MIN"",""SEC"" S:FMT[TIUI FMT=$P(FMT,TIUI)_@TIUI_$P(FMT,TIUI,2)"
1461^MAGD(2006.79,12,1,21,0)=" Q FMT"
1462^MAGD(2006.79,12,1,22,0)="DATE(X,FMT) ; Call with X=2910419.01 and FMT=Return Format of date (""MM/DD"")"
1463^MAGD(2006.79,12,1,23,0)=" N AMTH,MM,CC,DD,YY,TIUI,TIUTMP"
1464^MAGD(2006.79,12,1,24,0)=" I +X'>0 S $P(TIUTMP,"" "",$L($G(FMT))+1)="""",FMT=TIUTMP G QDATE"
1465^MAGD(2006.79,12,1,25,0)=" I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT=""MM/DD/YY"""
1466^MAGD(2006.79,12,1,26,0)=" S MM=$E(X,4,5),DD=$E(X,6,7),YY=$E(X,2,3),CC=17+$E(X)"
1467^MAGD(2006.79,12,1,27,0)=" S:FMT[""AMTH"" AMTH=$P(""JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"",""^"",+MM)"
1468^MAGD(2006.79,12,1,28,0)=" F TIUI=""AMTH"",""MM"",""DD"",""CC"",""YY"" S:FMT[TIUI FMT=$P(FMT,TIUI)_@TIUI_$P(FMT,TIUI,2)"
1469^MAGD(2006.79,12,1,29,0)=" I FMT[""HR"" S FMT=$$TIME(X,FMT)"
1470^MAGD(2006.79,12,1,30,0)="QDATE Q FMT"
1471^MAGD(2006.79,12,1,31,0)="NAME(X,FMT) ; Call with X=""LAST,FIRST MI"", FMT=Return Format (""LAST, FI"")"
1472^MAGD(2006.79,12,1,32,0)=" N TIULAST,TIULI,TIUFIRST,TIUFI,TIUMI,TIUI"
1473^MAGD(2006.79,12,1,33,0)=" I X']"""" S FMT="""" G NAMEX"
1474^MAGD(2006.79,12,1,34,0)=" I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT=""LAST,FIRST"""
1475^MAGD(2006.79,12,1,35,0)=" S FMT=$$LOWER(FMT)"
1476^MAGD(2006.79,12,1,36,0)=" S TIULAST=$P(X,"",""),TIULI=$E(TIULAST),TIUFIRST=$P(X,"","",2)"
1477^MAGD(2006.79,12,1,37,0)=" S TIUFI=$E(TIUFIRST)"
1478^MAGD(2006.79,12,1,38,0)=" S TIUMI=$S($P(TIUFIRST,"" "",2)'=""NMI"":$E($P(TIUFIRST,"" "",2)),1:"""")"
1479^MAGD(2006.79,12,1,39,0)=" S TIUFIRST=$P(TIUFIRST,"" "")"
1480^MAGD(2006.79,12,1,40,0)=" F TIUI=""last"",""li"",""first"",""fi"",""mi"" I FMT[TIUI S FMT=$P(FMT,TIUI)_@(""TIU""_$$UPPER(TIUI))_$P(FMT,TIUI,2)"
1481^MAGD(2006.79,12,1,41,0)="NAMEX Q FMT"
1482^MAGD(2006.79,12,1,42,0)="INAME(X) ; Call with X=""FIRST MI[.] LAST[,M.D.]"", RETURNS ""LAST,FIRST MI"""
1483^MAGD(2006.79,12,1,43,0)=" N LAST,FIRST,MIDDLE,NAME,MI"
1484^MAGD(2006.79,12,1,44,0)=" I X'?1.A1"" "".E S NAME=X G INAMEX"
1485^MAGD(2006.79,12,1,45,0)=" S NAME=$P(X,"",""),FIRST=$P(NAME,"" ""),MIDDLE=$S($L(NAME,"" "")=3:$P(NAME,"" "",2),1:"""")"
1486^MAGD(2006.79,12,1,46,0)=" S LAST=$P(NAME,"" "",$L(NAME,"" "")),MI=$S($L(MIDDLE):$E(MIDDLE),1:"""")"
1487^MAGD(2006.79,12,1,47,0)=" S NAME=LAST_"",""_FIRST_$S($L(MI):"" ""_MI,1:"""")"
1488^MAGD(2006.79,12,1,48,0)="INAMEX Q NAME"
1489^MAGD(2006.79,12,1,49,0)="WORD(X,FMT) ; Call with X=Word Processing array root, FMT=Wrap Width"
1490^MAGD(2006.79,12,1,50,0)=" N X,DIWL,DIWF,TIUI K ^UTILITY($J,""W"")"
1491^MAGD(2006.79,12,1,51,0)=" S DIWL=2,DIWF=""WRC""_FMT"
1492^MAGD(2006.79,12,1,52,0)=" S TIUI=0 F S TIUI=$O(@X@(TIUI)) Q:TIUI'>0 S X=^(TIUI,0) D ^DIWP"
1493^MAGD(2006.79,12,1,53,0)=" D ^DIWW K ^UTILITY($J,""W"")"
1494^MAGD(2006.79,12,1,54,0)=" Q """""
1495^MAGD(2006.79,12,1,55,0)="UPPER(X) ; Convert lower case X to UPPER CASE"
1496^MAGD(2006.79,12,1,56,0)=" Q $TR(X,""abcdefghijklmnopqrstuvwxyz"",""ABCDEFGHIJKLMNOPQRSTUVWXYZ"")"
1497^MAGD(2006.79,12,1,57,0)="LOWER(X) ; Convert UPPER CASE X to lower case"
1498^MAGD(2006.79,12,1,58,0)=" Q $TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZ"",""abcdefghijklmnopqrstuvwxyz"")"
1499^MAGD(2006.79,12,1,59,0)="MIXED(X) ; Return Mixed Case X"
1500^MAGD(2006.79,12,1,60,0)=" N TIUI,WORD,TMP"
1501^MAGD(2006.79,12,1,61,0)=" S TMP="""" F TIUI=1:1:$L(X,"" "") S WORD=$$UPPER($E($P(X,"" "",TIUI)))_$$LOWER($E($P(X,"" "",TIUI),2,$L($P(X,"" "",TIUI)))),TMP=$S(TMP="""":WORD,1:TMP_"" ""_WORD)"
1502^MAGD(2006.79,12,1,62,0)=" Q TMP"
1503^MAGD(2006.79,12,1,63,0)="STRIP(TEXT) ; Strips white space from text"
1504^MAGD(2006.79,12,1,64,0)=" N TIUTI,TIUX"
1505^MAGD(2006.79,12,1,65,0)=" ; First remove TABS"
1506^MAGD(2006.79,12,1,66,0)=" F TIUTI=1:1:$L(TEXT) S:$A(TEXT,TIUTI)=9 TEXT=$E(TEXT,1,(TIUTI-1))_"" ""_$E(TEXT,(TIUTI+1),$L(TEXT))"
1507^MAGD(2006.79,12,1,67,0)=" S TIUX="""" F TIUTI=1:1:$L(TEXT,"" "") S:$A($P(TEXT,"" "",TIUTI))>0 TIUX=TIUX_$S(TIUTI=1:"""",1:"" "")_$P(TEXT,"" "",TIUTI)"
1508^MAGD(2006.79,12,1,68,0)=" S TEXT=TIUX S:$P(TEXT,"" "")']"""" TEXT=$P(TEXT,"" "",2,$L(TEXT,"" ""))"
1509^MAGD(2006.79,12,1,69,0)=" Q TEXT"
1510^MAGD(2006.79,12,1,70,0)="SIGNAME(TIUDA) ; Get/Return Signature Block Printed Name"
1511^MAGD(2006.79,12,1,71,0)=" Q $P($G(^VA(200,+TIUDA,20)),U,2)"
1512^MAGD(2006.79,12,1,72,0)="SIGTITL(TIUDA) ; Get/Return Signature Block Printed Name"
1513^MAGD(2006.79,12,1,73,0)=" Q $P($G(^VA(200,+TIUDA,20)),U,3)"
1514^MAGD(2006.79,12,1,74,0)="CENTER(X) ; Center X"
1515^MAGD(2006.79,12,1,75,0)=" N SP"
1516^MAGD(2006.79,12,1,76,0)=" S $P(SP,"" "",((IOM-$L(X))\2))="""""
1517^MAGD(2006.79,12,1,77,0)=" Q $G(SP)_X"
1518^MAGD(2006.79,12,1,78,0)="URGENCY(X) ; Input transform for urgency codes"
1519^MAGD(2006.79,12,1,79,0)=" Q $S($$UPPER(X)=""STAT"":""P"",1:$E(X))"
1520^MAGD(2006.79,12,1,80,0)="FILL(X,Y,LEN) ; Append "", ""_X to Y, unless Y would excede LEN"
1521^MAGD(2006.79,12,1,81,0)=" Q $S('$L(Y):X,($L(Y_$C(44)_"" ""_X)'>LEN):Y_$C(44)_"" ""_X,1:X)"
1522^MAGD(2006.79,12,1,82,0)="PARSE(X,Y) ; Parse string X, return array Y with list of words from X"
1523^MAGD(2006.79,12,1,83,0)=" N I,WORD"
1524^MAGD(2006.79,12,1,84,0)=" F I=1:1:$L(X,"" "") D"
1525^MAGD(2006.79,12,1,85,0)=" . S WORD=$P(X,"" "",I),WORD=$TR(WORD,"".,!&?/|\{}[];:=+*^%$#@~`""""><"")"
1526^MAGD(2006.79,12,1,86,0)=" . S:WORD]"""" Y(I)=$$UPPER(WORD)"
1527^MAGD(2006.79,12,1,87,0)=" Q"
1528^MAGD(2006.79,12,1,88,0)="HASNUM(X) ; Boolean - evaluates whether X contains a number"
1529^MAGD(2006.79,12,1,89,0)=" N I,Y F I=0:1:9 I X[I S Y=1"
1530^MAGD(2006.79,12,1,90,0)=" Q +$G(Y)"
1531^MAGD(2006.79,12,1,91,0)="WRAP(TEXT,LENGTH) ; Breaks text string into substrings of length LENGTH"
1532^MAGD(2006.79,12,1,92,0)=" N TIUI,TIUJ,LINE,TIUX,TIUX1,TIUX2,TIUY"
1533^MAGD(2006.79,12,1,93,0)=" I $G(TEXT)']"""" Q """""
1534^MAGD(2006.79,12,1,94,0)=" F TIUI=1:1 D Q:TIUI=$L(TEXT,"" "")"
1535^MAGD(2006.79,12,1,95,0)=" . S TIUX=$P(TEXT,"" "",TIUI)"
1536^MAGD(2006.79,12,1,96,0)=" . I $L(TIUX)>LENGTH D"
1537^MAGD(2006.79,12,1,97,0)=" . . S TIUX1=$E(TIUX,1,LENGTH),TIUX2=$E(TIUX,LENGTH+1,$L(TIUX))"
1538^MAGD(2006.79,12,1,98,0)=" . . S $P(TEXT,"" "",TIUI)=TIUX1_"" ""_TIUX2"
1539^MAGD(2006.79,12,1,99,0)=" S LINE=1,TIUX(1)=$P(TEXT,"" "")"
1540^MAGD(2006.79,12,1,100,0)=" F TIUI=2:1 D Q:TIUI'<$L(TEXT,"" "")"
1541^MAGD(2006.79,12,1,101,0)=" . S:$L($G(TIUX(LINE))_"" ""_$P(TEXT,"" "",TIUI))>LENGTH LINE=LINE+1,TIUY=1"
1542^MAGD(2006.79,12,1,102,0)=" . S TIUX(LINE)=$G(TIUX(LINE))_$S(+$G(TIUY):"""",1:"" "")_$P(TEXT,"" "",TIUI),TIUY=0"
1543^MAGD(2006.79,12,1,103,0)=" S TIUJ=0,TEXT="""" F TIUI=1:1 S TIUJ=$O(TIUX(TIUJ)) Q:+TIUJ'>0 S TEXT=TEXT_$S(TIUI=1:"""",1:""|"")_TIUX(TIUJ)"
1544^MAGD(2006.79,12,1,104,0)=" Q TEXT"
1545^MAGD(2006.79,13,0)="TIUSRVPL^3050311.125837"
1546^MAGD(2006.79,13,1,0)="^2006.791^36^36"
1547^MAGD(2006.79,13,1,1,0)="TIUSRVPL ; SLC/JER - RPC's Supporting Links ;4/20/2001 09:46"
1548^MAGD(2006.79,13,1,2,0)=" ;;1.0;TEXT INTEGRATION UTILITIES;**63,114**;Jun 20, 1997"
1549^MAGD(2006.79,13,1,3,0)="PUTIMAGE(TIUY,TIUDA,IMGDA) ; Create link Image-to-Document"
1550^MAGD(2006.79,13,1,4,0)=" N D,D0,DI,DQ,DIC,DA,DIE,DR,X,Y"
1551^MAGD(2006.79,13,1,5,0)=" I $S('+$G(IMGDA):1,'$D(^MAG(2005,+IMGDA,0)):1,1:0) D Q"
1552^MAGD(2006.79,13,1,6,0)=" . S TIUY=""0^ Invalid Image Pointer."""
1553^MAGD(2006.79,13,1,7,0)=" I $S('+$G(TIUDA):1,'$D(^TIU(8925,+TIUDA,0)):1,1:0) D Q"
1554^MAGD(2006.79,13,1,8,0)=" . S TIUY=""0^ Invalid Document Pointer."""
1555^MAGD(2006.79,13,1,9,0)=" I $$DUPLINK(TIUDA,IMGDA) S TIUY=""0^ Document already linked to this image."" Q"
1556^MAGD(2006.79,13,1,10,0)=" S X=""""""""_""`""_TIUDA_"""""""",(DIC,DLAYGO)=8925.91,DIC(0)=""LX"""
1557^MAGD(2006.79,13,1,11,0)=" D ^DIC I +Y'>0 S TIUY=""0^ Unable to create Image Link"" Q"
1558^MAGD(2006.79,13,1,12,0)=" S TIUY=+Y"
1559^MAGD(2006.79,13,1,13,0)=" S DIE=DIC,DR="".02////^S X=IMGDA"" D ^DIE"
1560^MAGD(2006.79,13,1,14,0)=" Q"
1561^MAGD(2006.79,13,1,15,0)="DUPLINK(TIUDA,IMGDA) ; identify duplicate links"
1562^MAGD(2006.79,13,1,16,0)=" Q $S(+$O(^TIU(8925.91,""ADI"",+TIUDA,+IMGDA,0)):1,1:0)"
1563^MAGD(2006.79,13,1,17,0)="DELIMAGE(TIUY,TIUDA,IMGDA) ; Delete link Image-to-Document"
1564^MAGD(2006.79,13,1,18,0)=" N TIUI"
1565^MAGD(2006.79,13,1,19,0)=" I '+$O(^TIU(8925.91,""ADI"",TIUDA,IMGDA,0)) D Q"
1566^MAGD(2006.79,13,1,20,0)=" . S TIUY=""0^ Document and Image not currently linked."""
1567^MAGD(2006.79,13,1,21,0)=" S TIUI=0"
1568^MAGD(2006.79,13,1,22,0)=" F S TIUI=$O(^TIU(8925.91,""ADI"",TIUDA,IMGDA,TIUI)) Q:+TIUI'>0 D"
1569^MAGD(2006.79,13,1,23,0)=" . N DIDEL,DIE,DA,DR"
1570^MAGD(2006.79,13,1,24,0)=" . S (DIE,DIDEL)=8925.91,DR="".01///@"",DA=TIUI D ^DIE"
1571^MAGD(2006.79,13,1,25,0)=" S TIUY=1"
1572^MAGD(2006.79,13,1,26,0)=" Q"
1573^MAGD(2006.79,13,1,27,0)="GETILST(TIUY,TIUDA) ; Given a document, get list of associated images"
1574^MAGD(2006.79,13,1,28,0)=" N IMGDA,TIUI S (IMGDA,TIUI)=0"
1575^MAGD(2006.79,13,1,29,0)=" F S IMGDA=$O(^TIU(8925.91,""ADI"",TIUDA,IMGDA)) Q:+IMGDA'>0 D"
1576^MAGD(2006.79,13,1,30,0)=" . S TIUI=TIUI+1,TIUY(TIUI)=IMGDA"
1577^MAGD(2006.79,13,1,31,0)=" Q"
1578^MAGD(2006.79,13,1,32,0)="GETDLST(TIUY,IMGDA) ; Given an Image, get list of associated documents"
1579^MAGD(2006.79,13,1,33,0)=" N TIUDA,TIUI S (TIUDA,TIUI)=0"
1580^MAGD(2006.79,13,1,34,0)=" F S TIUDA=$O(^TIU(8925.91,""AID"",IMGDA,TIUDA)) Q:+TIUDA'>0 D"
1581^MAGD(2006.79,13,1,35,0)=" . S TIUI=TIUI+1,TIUY(TIUI)=TIUDA"
1582^MAGD(2006.79,13,1,36,0)=" Q"
1583^MAGD(2006.79,14,0)="VADPT^3050311.125837"
1584^MAGD(2006.79,14,1,0)="^2006.791^106^106"
1585^MAGD(2006.79,14,1,1,0)="VADPT ;ALB/MRL/MJK - RETURN PATIENT VARIABLE ARRAYS [DRIVER];07 DEC 1988"
1586^MAGD(2006.79,14,1,2,0)=" ;;5.3;Registration;**193,343,389,415,489,498**;Aug 13, 1993"
1587^MAGD(2006.79,14,1,3,0)=" ;DFN = Patient IFN [if not passed entire array returned as null]"
1588^MAGD(2006.79,14,1,4,0)=" ;"
1589^MAGD(2006.79,14,1,5,0)="DEM ;Demographic Variables"
1590^MAGD(2006.79,14,1,6,0)=" S VAN=1,VAN(1)=12,VAV=""VADM"" D ^VADPT0 Q"
1591^MAGD(2006.79,14,1,7,0)=" ;"
1592^MAGD(2006.79,14,1,8,0)="OPD ;Other Patient Data"
1593^MAGD(2006.79,14,1,9,0)=" S VAN=2,VAN(1)=7,VAV=""VAPD"" D ^VADPT0 Q"
1594^MAGD(2006.79,14,1,10,0)=" ;"
1595^MAGD(2006.79,14,1,11,0)="ADD ;Current Address"
1596^MAGD(2006.79,14,1,12,0)=" S VAN=3,VAN(1)=22,VAV=""VAPA"" D ^VADPT0 Q"
1597^MAGD(2006.79,14,1,13,0)=" ;"
1598^MAGD(2006.79,14,1,14,0)="OAD ;Other Patient Variables"
1599^MAGD(2006.79,14,1,15,0)=" S VAN=4,VAN(1)=11,VAV=""VAOA"" D ^VADPT0 Q"
1600^MAGD(2006.79,14,1,16,0)=" ;"
1601^MAGD(2006.79,14,1,17,0)="INP ;Inpatient Data [pre-version 5]"
1602^MAGD(2006.79,14,1,18,0)=" N VAINDTT S VAN=5,VAN(1)=11,VAV=""VAIN"",VAINDTT=$G(VAINDT) N VAINDT S:VAINDTT VAINDT=$$DATIM(VAINDTT) D ^VADPT0 Q"
1603^MAGD(2006.79,14,1,19,0)=" ;"
1604^MAGD(2006.79,14,1,20,0)="IN5 ;Inpatient Data [v5.0 and above]"
1605^MAGD(2006.79,14,1,21,0)=" N VAINDTT S VAN=6,VAN(1)=19,VAV=$S('$D(VAIP(""V"")):""VAIP"",VAIP(""V"")'?1A.E:""VAIP"",1:VAIP(""V"")),VAINDTT=$G(VAIP(""D"")) S:$L(VAINDTT) VAIP(""D"")=VAINDTT S:VAINDTT VAIP(""D"")=$$DATIM(VAINDTT) D ^VADPT0 S:$L(VAINDTT) VAIP(""D"")=VAINDTT Q"
1606^MAGD(2006.79,14,1,22,0)=" ;"
1607^MAGD(2006.79,14,1,23,0)="ELIG ;Eligibility Information"
1608^MAGD(2006.79,14,1,24,0)=" S VAN=7,VAN(1)=9,VAV=""VAEL"" D ^VADPT0 Q"
1609^MAGD(2006.79,14,1,25,0)=" ;"
1610^MAGD(2006.79,14,1,26,0)="MB ;Monetary Benefits"
1611^MAGD(2006.79,14,1,27,0)=" S VAN=8,VAN(1)=9,VAV=""VAMB"" D ^VADPT0 Q"
1612^MAGD(2006.79,14,1,28,0)=" ;"
1613^MAGD(2006.79,14,1,29,0)="SVC ;Service Information"
1614^MAGD(2006.79,14,1,30,0)=" S VAN=9,VAN(1)=9,VAV=""VASV"" D ^VADPT0 Q"
1615^MAGD(2006.79,14,1,31,0)=" ;"
1616^MAGD(2006.79,14,1,32,0)="REG ;Registration data"
1617^MAGD(2006.79,14,1,33,0)=" S VAN=10,VAV=""VARP"" D ^VADPT0 Q"
1618^MAGD(2006.79,14,1,34,0)=" ;"
1619^MAGD(2006.79,14,1,35,0)="SDE ;Enrollment Information"
1620^MAGD(2006.79,14,1,36,0)=" S VAN=11,VAV=""VAEN"" D ^VADPT0 Q"
1621^MAGD(2006.79,14,1,37,0)=" ;"
1622^MAGD(2006.79,14,1,38,0)="SDA ;Appointment Information"
1623^MAGD(2006.79,14,1,39,0)=" S VAN=12,VAV=""VASD"" D ^VADPT0 Q"
1624^MAGD(2006.79,14,1,40,0)=" ;"
1625^MAGD(2006.79,14,1,41,0)="PID ;Patient Id"
1626^MAGD(2006.79,14,1,42,0)=" S VAN=13,VAV=""VA"" D ^VADPT0 Q"
1627^MAGD(2006.79,14,1,43,0)=" ;"
1628^MAGD(2006.79,14,1,44,0)="TESTPAT(DFN) ;Test patient ? Returns 0 (No) or 1 (Yes)"
1629^MAGD(2006.79,14,1,45,0)=" S DFN=+$G(DFN) I 'DFN Q 0"
1630^MAGD(2006.79,14,1,46,0)=" I $D(^DPT(""ATEST"",DFN)) Q 1"
1631^MAGD(2006.79,14,1,47,0)=" N NODE S NODE=$G(^DPT(DFN,0))"
1632^MAGD(2006.79,14,1,48,0)=" I $P(NODE,""^"",21)=1 Q 1"
1633^MAGD(2006.79,14,1,49,0)=" I $E($P(NODE,""^"",9),1,5)=""00000"" Q 1"
1634^MAGD(2006.79,14,1,50,0)=" Q 0"
1635^MAGD(2006.79,14,1,51,0)=" ;"
1636^MAGD(2006.79,14,1,52,0)="V5 S X=$S($D(^DG(43,1,""VERSION"")):+^(""VERSION""),1:""""),VADPT(""V"")=$S(X<5:0,1:1) K X Q"
1637^MAGD(2006.79,14,1,53,0)="OERR ;"
1638^MAGD(2006.79,14,1,54,0)="1 S VATAG=1 D MULT Q"
1639^MAGD(2006.79,14,1,55,0)="2 S VATAG=2 D MULT Q"
1640^MAGD(2006.79,14,1,56,0)="3 S VATAG=3 D MULT Q"
1641^MAGD(2006.79,14,1,57,0)="4 S VATAG=4 D MULT Q"
1642^MAGD(2006.79,14,1,58,0)="5 S VATAG=5 D MULT Q"
1643^MAGD(2006.79,14,1,59,0)="6 S VATAG=6 D MULT Q"
1644^MAGD(2006.79,14,1,60,0)="7 S VATAG=7 D MULT Q"
1645^MAGD(2006.79,14,1,61,0)="8 S VATAG=8 D MULT Q"
1646^MAGD(2006.79,14,1,62,0)="9 S VATAG=9 D MULT Q"
1647^MAGD(2006.79,14,1,63,0)="10 S VATAG=10 D MULT Q"
1648^MAGD(2006.79,14,1,64,0)="51 S VATAG=11 D MULT Q"
1649^MAGD(2006.79,14,1,65,0)="52 S VATAG=12 D MULT Q"
1650^MAGD(2006.79,14,1,66,0)="53 S VATAG=13 D MULT Q"
1651^MAGD(2006.79,14,1,67,0)="ALL S VATAG=14 D MULT Q"
1652^MAGD(2006.79,14,1,68,0)="A5 S VATAG=15 D MULT Q"
1653^MAGD(2006.79,14,1,69,0)="SEL Q:$O(VARRAY(0))']"""" S VATAG=0,VATAG(2)=$P($T(TAG),"";;"",2)"
1654^MAGD(2006.79,14,1,70,0)=" F VATAG(1)=0:0 S VATAG=$O(VARRAY(VATAG)) Q:VATAG="""" I VATAG(2)[(""^""_VATAG_""^"") S VARRAY(VATAG)=1,VAROOT=$S($D(VAROOT(VATAG)):VAROOT(VATAG),1:"""") D @VATAG"
1655^MAGD(2006.79,14,1,71,0)=" G Q"
1656^MAGD(2006.79,14,1,72,0)=" ;"
1657^MAGD(2006.79,14,1,73,0)="MULT S VATAG=$P($T(TG+VATAG),"";;"",2)"
1658^MAGD(2006.79,14,1,74,0)=" F VATAG(1)=1:1 S VATAG(2)=$P(VATAG,""^"",VATAG(1)) Q:VATAG(2)="""" S VAROOT=$S($D(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"""") D @(VATAG(2))"
1659^MAGD(2006.79,14,1,75,0)="Q S VAROOT="""" K:$D(VAROOT)'=11 VAROOT K VATAG Q"
1660^MAGD(2006.79,14,1,76,0)=" ;"
1661^MAGD(2006.79,14,1,77,0)="KVA K VA"
1662^MAGD(2006.79,14,1,78,0)="KVAR D KVAR^VADPT0 K:$D(VAIP(""V"")) @(VAIP(""V"")) K I,X,Y,VARRAY,VADM,VAPD,VADPT,VAOA,VASV,VAEL,VAMB,VARP,VAEN,VASD,VAIN,VAIP,VAPA,VAHOW,VAINDT,VAERR,^UTILITY(""VADPT"",$J),VA200,VATEST Q"
1663^MAGD(2006.79,14,1,79,0)="DATIM(DATIM) ;If time not specified see if movement on that date"
1664^MAGD(2006.79,14,1,80,0)=" Q:DATIM'?7N DATIM"
1665^MAGD(2006.79,14,1,81,0)=" N A,B S A=$O(^DGPM(""ADFN""_DFN,DATIM)),B=+$O(^(+A,0))"
1666^MAGD(2006.79,14,1,82,0)=" I 'A Q DATIM"
1667^MAGD(2006.79,14,1,83,0)=" I $P($G(^DGPM(+B,0)),""^"",2)=3 Q DATIM ;Next movement is discharge"
1668^MAGD(2006.79,14,1,84,0)=" F Q:""^4^5^7^""'[(U_$P($G(^DGPM(+B,0)),""^"",2)) S A=$O(^DGPM(""ADFN""_DFN,A)),B=+$O(^(+A,0)) I $E(A,1,7)'=DATIM Q"
1669^MAGD(2006.79,14,1,85,0)=" I 'A Q DATIM"
1670^MAGD(2006.79,14,1,86,0)=" I $E(A,1,7)'=DATIM Q DATIM"
1671^MAGD(2006.79,14,1,87,0)=" Q A"
1672^MAGD(2006.79,14,1,88,0)=" ;"
1673^MAGD(2006.79,14,1,89,0)="TG ;"
1674^MAGD(2006.79,14,1,90,0)=" ;;DEM^INP"
1675^MAGD(2006.79,14,1,91,0)=" ;;DEM^ELIG"
1676^MAGD(2006.79,14,1,92,0)=" ;;ELIG^INP"
1677^MAGD(2006.79,14,1,93,0)=" ;;DEM^ADD"
1678^MAGD(2006.79,14,1,94,0)=" ;;ADD^INP"
1679^MAGD(2006.79,14,1,95,0)=" ;;DEM^ELIG^ADD"
1680^MAGD(2006.79,14,1,96,0)=" ;;ELIG^SVC"
1681^MAGD(2006.79,14,1,97,0)=" ;;ELIG^SVC^MB"
1682^MAGD(2006.79,14,1,98,0)=" ;;DEM^REG^SDE^SDA"
1683^MAGD(2006.79,14,1,99,0)=" ;;SDE^SDA"
1684^MAGD(2006.79,14,1,100,0)=" ;;DEM^IN5"
1685^MAGD(2006.79,14,1,101,0)=" ;;ELIG^IN5"
1686^MAGD(2006.79,14,1,102,0)=" ;;ADD^IN5"
1687^MAGD(2006.79,14,1,103,0)=" ;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA"
1688^MAGD(2006.79,14,1,104,0)=" ;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA"
1689^MAGD(2006.79,14,1,105,0)=" ;"
1690^MAGD(2006.79,14,1,106,0)="TAG ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^"
1691^MAGD(2006.79,15,0)="VADPT0^3050311.125837"
1692^MAGD(2006.79,15,1,0)="^2006.791^100^100"
1693^MAGD(2006.79,15,1,1,0)="VADPT0 ;ALB/MRL/MJK - PATIENT VARIABLE ROUTINE DRIVER, CONT.; 12 DEC 1988"
1694^MAGD(2006.79,15,1,2,0)=" ;;5.3;Registration;**343,342,415,489,498,528**;Aug 13, 1993"
1695^MAGD(2006.79,15,1,3,0)=" ;"
1696^MAGD(2006.79,15,1,4,0)=" ;Initialize variables"
1697^MAGD(2006.79,15,1,5,0)=" N I1"
1698^MAGD(2006.79,15,1,6,0)=" S U=""^"" D DT^DICRW:'$D(DT)"
1699^MAGD(2006.79,15,1,7,0)=" S VAERR=$S('$D(DFN)#2:1,'$D(^DPT(DFN,0)):1,1:0)"
1700^MAGD(2006.79,15,1,8,0)=" S Y=VAN'=13 I Y,$D(VAROOT)'[0,VAROOT]"""" S Y=0,VAV=VAROOT K @VAV"
1701^MAGD(2006.79,15,1,9,0)=" I Y S:$S(VAN>9:1,'$D(VAHOW):0,1:VAHOW[2) VAV=""^UTILITY(""_""""""""_VAV_""""""""_"",""_$J_"")"""
1702^MAGD(2006.79,15,1,10,0)=" D @VAN"
1703^MAGD(2006.79,15,1,11,0)="Q K X,Y,VAC,VAS,VAV,VAW,VAN,I,VAX,VAZ Q"
1704^MAGD(2006.79,15,1,12,0)=" ;"
1705^MAGD(2006.79,15,1,13,0)="INIT ; -- determine #'s or names then init array"
1706^MAGD(2006.79,15,1,14,0)=" ;"
1707^MAGD(2006.79,15,1,15,0)=" S VAS=""1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25"""
1708^MAGD(2006.79,15,1,16,0)=" I VAN<10,$D(VAHOW),VAHOW[1 S VAS=$P($T(SS+VAN),"";;"",2)"
1709^MAGD(2006.79,15,1,17,0)=" I $D(VAN(1)) F I=1:1:VAN(1) S @VAV@($P(VAS,""^"",I))="""""
1710^MAGD(2006.79,15,1,18,0)=" Q"
1711^MAGD(2006.79,15,1,19,0)=" ;"
1712^MAGD(2006.79,15,1,20,0)="1 ; -- [DEM] demos "
1713^MAGD(2006.79,15,1,21,0)=" D C1,INIT I 'VAERR D 1^VADPT1,13 Q"
1714^MAGD(2006.79,15,1,22,0)=" ;"
1715^MAGD(2006.79,15,1,23,0)="2 ; -- [OPD] other pt vars"
1716^MAGD(2006.79,15,1,24,0)=" D C2,INIT,2^VADPT1:'VAERR Q"
1717^MAGD(2006.79,15,1,25,0)=" ;"
1718^MAGD(2006.79,15,1,26,0)="3 ; -- [ADD] current address"
1719^MAGD(2006.79,15,1,27,0)=" D C3,INIT,3^VADPT1:'VAERR Q"
1720^MAGD(2006.79,15,1,28,0)=" ;"
1721^MAGD(2006.79,15,1,29,0)="4 ; -- [OAD] other pt vars"
1722^MAGD(2006.79,15,1,30,0)=" D C4,INIT,4^VADPT1:'VAERR Q"
1723^MAGD(2006.79,15,1,31,0)=" ;"
1724^MAGD(2006.79,15,1,32,0)="5 ; -- [INP] inpt data -v5"
1725^MAGD(2006.79,15,1,33,0)=" D C5,INIT,5^VADPT2:'VAERR Q"
1726^MAGD(2006.79,15,1,34,0)=" ;"
1727^MAGD(2006.79,15,1,35,0)="6 ; -- [IN5] inpt data v5"
1728^MAGD(2006.79,15,1,36,0)=" D C6,INIT F I=13:1:17 F I1=1:1:7 S @VAV@($P(VAS,""^"",I),I1)="""""
1729^MAGD(2006.79,15,1,37,0)=" F I=1:1:3 S @VAV@($P(VAS,""^"",19),I)="""""
1730^MAGD(2006.79,15,1,38,0)=" D 6^VADPT3:'VAERR Q"
1731^MAGD(2006.79,15,1,39,0)=" ;"
1732^MAGD(2006.79,15,1,40,0)="7 ; -- [ELIG] elig data"
1733^MAGD(2006.79,15,1,41,0)=" D C7,INIT F I=1:1:6 S @VAV@($P(VAS,""^"",5),I)="""""
1734^MAGD(2006.79,15,1,42,0)=" D 7^VADPT4:'VAERR Q"
1735^MAGD(2006.79,15,1,43,0)=" ;"
1736^MAGD(2006.79,15,1,44,0)="8 ; -- [MB] $ benefits"
1737^MAGD(2006.79,15,1,45,0)=" D C8,INIT D 8^VADPT4:'VAERR Q"
1738^MAGD(2006.79,15,1,46,0)=" ;"
1739^MAGD(2006.79,15,1,47,0)="9 ; -- [SVC] service data"
1740^MAGD(2006.79,15,1,48,0)=" D C9,INIT F I=1:1:9 S @VAV@($P(VAS,""^"",I),1)="""",@VAV@($P(VAS,""^"",I),2)="""""
1741^MAGD(2006.79,15,1,49,0)=" S @VAV@($P(VAS,""^"",10),1)="""""
1742^MAGD(2006.79,15,1,50,0)=" S @VAV@($P(VAS,""^"",4),3)="""",@VAV@($P(VAS,""^"",5),3)="""""
1743^MAGD(2006.79,15,1,51,0)=" F I=2,6,7,8 F I1=3,4,5 S @VAV@($P(VAS,""^"",I),I1)="""""
1744^MAGD(2006.79,15,1,52,0)=" D 9^VADPT4:'VAERR Q"
1745^MAGD(2006.79,15,1,53,0)=" ;"
1746^MAGD(2006.79,15,1,54,0)="10 ; -- [REG] registration data"
1747^MAGD(2006.79,15,1,55,0)=" D C10,INIT D 10^VADPT5:'VAERR Q"
1748^MAGD(2006.79,15,1,56,0)=" ;"
1749^MAGD(2006.79,15,1,57,0)="11 ; -- [SDE] clinic enrollment data"
1750^MAGD(2006.79,15,1,58,0)=" D C11,INIT D 11^VADPT5:'VAERR Q"
1751^MAGD(2006.79,15,1,59,0)=" ;"
1752^MAGD(2006.79,15,1,60,0)="12 ; -- [SDA] appt data"
1753^MAGD(2006.79,15,1,61,0)=" D C12,INIT D 12^VADPT5:'VAERR Q"
1754^MAGD(2006.79,15,1,62,0)=" ;"
1755^MAGD(2006.79,15,1,63,0)="13 ; -- [PID] pt id's"
1756^MAGD(2006.79,15,1,64,0)=" S (VA(""PID""),VA(""BID""))="""" D 13^VADPT6:'VAERR Q"
1757^MAGD(2006.79,15,1,65,0)=" ;"
1758^MAGD(2006.79,15,1,66,0)="KVAR ; kill all vadpt data"
1759^MAGD(2006.79,15,1,67,0)=" K VAN"
1760^MAGD(2006.79,15,1,68,0)="C1 K ^UTILITY(""VADM"",$J),VADM Q:$D(VAN)"
1761^MAGD(2006.79,15,1,69,0)="C2 K ^UTILITY(""VAPD"",$J),VAPD Q:$D(VAN)"
1762^MAGD(2006.79,15,1,70,0)="C3 K X S:$D(VAPA(""P"")) X(""P"")=VAPA(""P"")"
1763^MAGD(2006.79,15,1,71,0)=" S:$D(VAPA(""CD"")) X(""CD"")=VAPA(""CD"")"
1764^MAGD(2006.79,15,1,72,0)=" K ^UTILITY(""VAPA"",$J),VAPA"
1765^MAGD(2006.79,15,1,73,0)=" S:$D(X(""P"")) VAPA(""P"")=X(""P"") K X(""P"")"
1766^MAGD(2006.79,15,1,74,0)=" S:$D(X(""CD"")) VAPA(""CD"")=X(""CD"") K X Q:$D(VAN)"
1767^MAGD(2006.79,15,1,75,0)="C4 K X S:$D(VAOA(""A"")) X(""A"")=VAOA(""A"")"
1768^MAGD(2006.79,15,1,76,0)=" K ^UTILITY(""VAOA"",$J),VAOA"
1769^MAGD(2006.79,15,1,77,0)=" S:$D(X(""A"")) VAOA(""A"")=X(""A"") K X Q:$D(VAN)"
1770^MAGD(2006.79,15,1,78,0)="C5 K ^UTILITY(""VAIN"",$J),VAIN Q:$D(VAN)"
1771^MAGD(2006.79,15,1,79,0)="C6 K X F I=""D"",""E"",""L"",""M"",""V"" I $D(VAIP(I)) S X(I)=VAIP(I)"
1772^MAGD(2006.79,15,1,80,0)=" S Y=$S('$D(VAIP(""V"")):""VAIP"",VAIP(""V"")'?1A.E:""VAIP"",1:VAIP(""V"")) K ^UTILITY(Y,$J),@Y"
1773^MAGD(2006.79,15,1,81,0)=" F I=""D"",""E"",""L"",""M"",""V"" I $D(X(I)) S VAIP(I)=X(I)"
1774^MAGD(2006.79,15,1,82,0)=" K X Q:$D(VAN)"
1775^MAGD(2006.79,15,1,83,0)="C7 K ^UTILITY(""VAEL"",$J),VAEL Q:$D(VAN)"
1776^MAGD(2006.79,15,1,84,0)="C8 K ^UTILITY(""VAMB"",$J),VAMB Q:$D(VAN)"
1777^MAGD(2006.79,15,1,85,0)="C9 K ^UTILITY(""VASV"",$J),VASV Q:$D(VAN)"
1778^MAGD(2006.79,15,1,86,0)="C10 K ^UTILITY(""VARP"",$J) Q:$D(VAN)"
1779^MAGD(2006.79,15,1,87,0)="C11 K ^UTILITY(""VAEN"",$J) Q:$D(VAN)"
1780^MAGD(2006.79,15,1,88,0)="C12 K ^UTILITY(""VASD"",$J) Q"
1781^MAGD(2006.79,15,1,89,0)="C13 Q"
1782^MAGD(2006.79,15,1,90,0)=" ;"
1783^MAGD(2006.79,15,1,91,0)="SS ; 1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25"
1784^MAGD(2006.79,15,1,92,0)=" ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS^ET^RC"
1785^MAGD(2006.79,15,1,93,0)=" ;;BC^BS^FN^MN^MM^OC^ES"
1786^MAGD(2006.79,15,1,94,0)=" ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE^Z4^CCA^CL1^CL2^CL3^CCI^CST^CZP^CCO^CCS^CCE^CTY"
1787^MAGD(2006.79,15,1,95,0)=" ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE^Z4"
1788^MAGD(2006.79,15,1,96,0)=" ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT^AP"
1789^MAGD(2006.79,15,1,97,0)=" ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN^AP^FD"
1790^MAGD(2006.79,15,1,98,0)=" ;;EL^PS^SC^VT^IN^TY^CN^ES^MT"
1791^MAGD(2006.79,15,1,99,0)=" ;;AA^HB^SS^PE^MR^SI^DI^OR^GI"
1792^MAGD(2006.79,15,1,100,0)=" ;;VN^AO^IR^PW^CS^S1^S2^S3^PH"
1793^MAGD(2006.79,16,0)="VADPT1^3050311.125837"
1794^MAGD(2006.79,16,1,0)="^2006.791^126^126"
1795^MAGD(2006.79,16,1,1,0)="VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES ; 08 DEC 1988 ; 11/9/04 6:17pm"
1796^MAGD(2006.79,16,1,2,0)=" ;;5.3;Registration;**415,489,516,614**;Aug 13, 1993"
1797^MAGD(2006.79,16,1,3,0)="1 ;Demographic [DEM]"
1798^MAGD(2006.79,16,1,4,0)=" N W,Z,NODE"
1799^MAGD(2006.79,16,1,5,0)=" ;"
1800^MAGD(2006.79,16,1,6,0)=" ; -- name [1 - NM]"
1801^MAGD(2006.79,16,1,7,0)=" S VAX=^DPT(DFN,0),@VAV@($P(VAS,""^"",1))=$P(VAX,""^"")"
1802^MAGD(2006.79,16,1,8,0)=" ;"
1803^MAGD(2006.79,16,1,9,0)=" ; -- ssn [2 - SS]"
1804^MAGD(2006.79,16,1,10,0)=" S Z=$P(VAX,""^"",9) S:Z]"""" @VAV@($P(VAS,""^"",2))=Z_$S(Z]"""":""^""_$E(Z,1,3)_""-""_$E(Z,4,5)_""-""_$E(Z,6,10),1:"""")"
1805^MAGD(2006.79,16,1,11,0)=" ;"
1806^MAGD(2006.79,16,1,12,0)=" ; -- date of birth [2 - DB]"
1807^MAGD(2006.79,16,1,13,0)=" S Z=$P(VAX,""^"",3),Y=Z I Y]"""" X ^DD(""DD"") S @VAV@($P(VAS,""^"",3))=Z_""^""_Y"
1808^MAGD(2006.79,16,1,14,0)=" ;"
1809^MAGD(2006.79,16,1,15,0)=" ; -- age [4 - AG]"
1810^MAGD(2006.79,16,1,16,0)=" S W=$S('$D(^DPT(DFN,.35)):"""",'^(.35):"""",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"""" @VAV@($P(VAS,""^"",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))"
1811^MAGD(2006.79,16,1,17,0)=" ;"
1812^MAGD(2006.79,16,1,18,0)=" ; -- expired date [6 - EX]"
1813^MAGD(2006.79,16,1,19,0)=" S (Y,Z)=W X:Y]"""" ^DD(""DD"") S:Z]"""" @VAV@($P(VAS,""^"",6))=Z_""^""_Y"
1814^MAGD(2006.79,16,1,20,0)=" ;"
1815^MAGD(2006.79,16,1,21,0)=" ; -- sex [5 - SX]"
1816^MAGD(2006.79,16,1,22,0)=" S Z=$P(VAX,""^"",2) S:Z]"""" @VAV@($P(VAS,""^"",5))=Z_""^""_$S(Z=""M"":""MALE"",Z=""F"":""FEMALE"",1:"""") K Z"
1817^MAGD(2006.79,16,1,23,0)=" ;"
1818^MAGD(2006.79,16,1,24,0)=" ; -- remarks [7 - RE]"
1819^MAGD(2006.79,16,1,25,0)=" S @VAV@($P(VAS,""^"",7))=$P(VAX,""^"",10)"
1820^MAGD(2006.79,16,1,26,0)=" ;"
1821^MAGD(2006.79,16,1,27,0)=" ; -- historic race [8 - RA]"
1822^MAGD(2006.79,16,1,28,0)=" S Z=$P(VAX,""^"",6),@VAV@($P(VAS,""^"",8))=Z_$S($D(^DIC(10,+Z,0)):""^""_$P(^(0),""^""),1:"""")"
1823^MAGD(2006.79,16,1,29,0)=" ;"
1824^MAGD(2006.79,16,1,30,0)=" ; -- religion [9 - RP]"
1825^MAGD(2006.79,16,1,31,0)=" S Z=$P(VAX,""^"",8),@VAV@($P(VAS,""^"",9))=Z_$S($D(^DIC(13,+Z,0)):""^""_$P(^(0),""^""),1:"""")"
1826^MAGD(2006.79,16,1,32,0)=" ;"
1827^MAGD(2006.79,16,1,33,0)=" ; -- marital status [10 - MS]"
1828^MAGD(2006.79,16,1,34,0)=" S Z=$P(VAX,""^"",5),@VAV@($P(VAS,""^"",10))=Z_$S($D(^DIC(11,+Z,0)):""^""_$P(^(0),""^""),1:"""")"
1829^MAGD(2006.79,16,1,35,0)=" ;"
1830^MAGD(2006.79,16,1,36,0)=" ; -- ethnicity [11 - ET]"
1831^MAGD(2006.79,16,1,37,0)=" S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X D"
1832^MAGD(2006.79,16,1,38,0)=" .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,""^"",1) I Z D"
1833^MAGD(2006.79,16,1,39,0)=" ..S @VAV@($P(VAS,""^"",11),Y)=Z_""^""_$P($G(^DIC(10.2,Z,0)),""^"",1)"
1834^MAGD(2006.79,16,1,40,0)=" ..; -- collection method"
1835^MAGD(2006.79,16,1,41,0)=" ..S Z=$P(NODE,""^"",2) I Z D"
1836^MAGD(2006.79,16,1,42,0)=" ...S @VAV@($P(VAS,""^"",11),Y,1)=Z_""^""_$P($G(^DIC(10.3,Z,0)),""^"",1)"
1837^MAGD(2006.79,16,1,43,0)=" S @VAV@($P(VAS,""^"",11))=Y-1"
1838^MAGD(2006.79,16,1,44,0)=" ;"
1839^MAGD(2006.79,16,1,45,0)=" ; -- race [12 - RC]"
1840^MAGD(2006.79,16,1,46,0)=" S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X D"
1841^MAGD(2006.79,16,1,47,0)=" .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,""^"",1) I Z D"
1842^MAGD(2006.79,16,1,48,0)=" ..S @VAV@($P(VAS,""^"",12),Y)=Z_""^""_$P($G(^DIC(10,Z,0)),""^"",1)"
1843^MAGD(2006.79,16,1,49,0)=" ..; -- collection method"
1844^MAGD(2006.79,16,1,50,0)=" ..S Z=$P(NODE,""^"",2) I Z D"
1845^MAGD(2006.79,16,1,51,0)=" ...S @VAV@($P(VAS,""^"",12),Y,1)=Z_""^""_$P($G(^DIC(10.3,Z,0)),""^"",1)"
1846^MAGD(2006.79,16,1,52,0)=" S @VAV@($P(VAS,""^"",12))=Y-1"
1847^MAGD(2006.79,16,1,53,0)=" Q"
1848^MAGD(2006.79,16,1,54,0)=" ;"
1849^MAGD(2006.79,16,1,55,0)="2 ;Other Patient Variables [OPD]"
1850^MAGD(2006.79,16,1,56,0)=" N W,Z"
1851^MAGD(2006.79,16,1,57,0)=" S VAX=^DPT(DFN,0)"
1852^MAGD(2006.79,16,1,58,0)=" ;"
1853^MAGD(2006.79,16,1,59,0)=" ; -- city of birth [1 - BC]"
1854^MAGD(2006.79,16,1,60,0)=" S @VAV@($P(VAS,""^"",1))=$P(VAX,""^"",11)"
1855^MAGD(2006.79,16,1,61,0)=" ;"
1856^MAGD(2006.79,16,1,62,0)=" ; -- state of birth [2 - BS]"
1857^MAGD(2006.79,16,1,63,0)=" S Z=$P(VAX,""^"",12),@VAV@($P(VAS,""^"",2))=Z_$S($D(^DIC(5,+Z,0)):""^""_$P(^(0),""^"",1),1:"""")"
1858^MAGD(2006.79,16,1,64,0)=" ;"
1859^MAGD(2006.79,16,1,65,0)=" ; -- occupation [6 - OC]"
1860^MAGD(2006.79,16,1,66,0)=" S @VAV@($P(VAS,""^"",6))=$P(VAX,""^"",7)"
1861^MAGD(2006.79,16,1,67,0)=" ;"
1862^MAGD(2006.79,16,1,68,0)=" ; -- names"
1863^MAGD(2006.79,16,1,69,0)=" S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"""")"
1864^MAGD(2006.79,16,1,70,0)=" S @VAV@($P(VAS,""^"",3))=$P(VAX,""^"",1) ; father's [3 - FN]"
1865^MAGD(2006.79,16,1,71,0)=" S @VAV@($P(VAS,""^"",4))=$P(VAX,""^"",2) ; mother's [4 - MN]"
1866^MAGD(2006.79,16,1,72,0)=" S @VAV@($P(VAS,""^"",5))=$P(VAX,""^"",3) ; mother's maiden [5 - MM]"
1867^MAGD(2006.79,16,1,73,0)=" ;"
1868^MAGD(2006.79,16,1,74,0)=" ; -- employment status [7 - ES]"
1869^MAGD(2006.79,16,1,75,0)=" S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""""),W=""EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"""
1870^MAGD(2006.79,16,1,76,0)=" S Z=$P(VAX,""^"",15),@VAV@($P(VAS,""^"",7))=Z_$S(Z:""^""_$P(W,""^"",Z),1:"""")"
1871^MAGD(2006.79,16,1,77,0)=" Q"
1872^MAGD(2006.79,16,1,78,0)=" ;"
1873^MAGD(2006.79,16,1,79,0)="3 ;Address [ADD]"
1874^MAGD(2006.79,16,1,80,0)=" S VABEG=$S($D(VATEST(""ADD"",9)):VATEST(""ADD"",9),1:DT),VAEND=$S($D(VATEST(""ADD"",10)):VATEST(""ADD"",10),1:DT)"
1875^MAGD(2006.79,16,1,81,0)=" I $S($D(VAPA(""P"")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),""^"",9)'=""Y"":1,'$P(^(.121),""^"",7):1,$P(^(.121),""^"",7)>VABEG:1,'$P(^(.121),""^"",8):0,1:$P(^(.121),""^"",8)<VAEND) S VAX=$S($D(^DPT(DFN,.11)):^(.11),1:""""),VAX(1)=0"
1876^MAGD(2006.79,16,1,82,0)=" E S VAX=$S($D(^DPT(DFN,.121)):^(.121),1:""""),VAX(1)=1"
1877^MAGD(2006.79,16,1,83,0)=" F I=1:1:6 S VAZ=$P(VAX,""^"",I),@VAV@($P(VAS,""^"",I))=VAZ I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),""^""),@VAV@($P(VAS,""^"",5))=@VAV@($P(VAS,""^"",5))_""^""_VAZ"
1878^MAGD(2006.79,16,1,84,0)=" S VAZ=$S('VAX(1):$P(VAX,""^"",7),1:$P(VAX,""^"",11)) S:$D(^DIC(5,+$P(VAX,""^"",5),1,+VAZ,0)) VAZ=VAZ_""^""_$P(^(0),""^"",1) S @VAV@($P(VAS,""^"",7))=VAZ"
1879^MAGD(2006.79,16,1,85,0)=" S VAZIP4=$P(VAX,U,12)"
1880^MAGD(2006.79,16,1,86,0)=" S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"""",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_""-""_$E(VAZIP4,6,9))"
1881^MAGD(2006.79,16,1,87,0)=" ;DG*5.3*516"
1882^MAGD(2006.79,16,1,88,0)=" I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,""^"",8))=$P(^(.13),""^"",1)"
1883^MAGD(2006.79,16,1,89,0)=" I 'VAX(1) G CA"
1884^MAGD(2006.79,16,1,90,0)=" S @VAV@($P(VAS,""^"",8))=$P(VAX,""^"",10)"
1885^MAGD(2006.79,16,1,91,0)=" F I=7,8 S VAZ=$P(VAX,""^"",I),Y=VAZ X:Y]"""" ^DD(""DD"") S @VAV@($P(VAS,""^"",I+2))=VAZ_""^""_Y"
1886^MAGD(2006.79,16,1,92,0)="CA ;Confidential Address"
1887^MAGD(2006.79,16,1,93,0)=" I '$D(^DPT(DFN,.141)) G Q3"
1888^MAGD(2006.79,16,1,94,0)=" N VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN"
1889^MAGD(2006.79,16,1,95,0)=" S VAX=$S($D(^DPT(DFN,.141)):^(.141),1:"""")"
1890^MAGD(2006.79,16,1,96,0)=" S VAACTDT=$S($D(VAPA(""CD"")):VAPA(""CD""),1:DT)"
1891^MAGD(2006.79,16,1,97,0)=" F I=1:1:6 S VAZ=$P(VAX,""^"",I),@VAV@($P(VAS,""^"",I+12))=VAZ D"
1892^MAGD(2006.79,16,1,98,0)=" .I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),""^""),@VAV@($P(VAS,""^"",I+12))=@VAV@($P(VAS,""^"",I+12))_""^""_VAZ Q"
1893^MAGD(2006.79,16,1,99,0)=" .I I=6,($G(VAZ)]"""") S @VAV@($P(VAS,""^"",I+12))=@VAV@($P(VAS,""^"",I+12))_""^""_$S(($L(VAZ)=5):VAZ,1:$E(VAZ,1,5)_""-""_$E(VAZ,6,9))"
1894^MAGD(2006.79,16,1,100,0)=" S VAZ=$P(VAX,""^"",11) S:$D(^DIC(5,+$P(VAX,""^"",5),1,+VAZ,0)) VAZ=VAZ_""^""_$P(^(0),""^"",1) S @VAV@($P(VAS,""^"",19))=VAZ"
1895^MAGD(2006.79,16,1,101,0)=" F I=7,8 S VAZ=$P(VAX,""^"",I),Y=VAZ X:Y]"""" ^DD(""DD"") S @VAV@($P(VAS,""^"",I+13))=VAZ_""^""_Y"
1896^MAGD(2006.79,16,1,102,0)=" S VABEG=$P(VAX,""^"",7),VAEND=$P(VAX,""^"",8)"
1897^MAGD(2006.79,16,1,103,0)=" S @VAV@($P(VAS,""^"",12))=1"
1898^MAGD(2006.79,16,1,104,0)=" I 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT)) S @VAV@($P(VAS,""^"",12))=0"
1899^MAGD(2006.79,16,1,105,0)=" I $D(^DPT(DFN,.14)) D"
1900^MAGD(2006.79,16,1,106,0)=" .S VACAN="""" F S VACAN=$O(^DPT(DFN,.14,VACAN)) Q:VACAN="""" D"
1901^MAGD(2006.79,16,1,107,0)=" ..Q:'$D(^DPT(DFN,.14,VACAN,0))"
1902^MAGD(2006.79,16,1,108,0)=" ..S VATYP=$P(^DPT(DFN,.14,VACAN,0),""^"",1),VAACT=$P(^DPT(DFN,.14,VACAN,0),""^"",2)"
1903^MAGD(2006.79,16,1,109,0)=" ..S VACAT=$$GET1^DID(2.141,.01,"""",""POINTER"","""",""DGERR"")"
1904^MAGD(2006.79,16,1,110,0)=" ..S VATYPNAM="""" F I=1:1 S VATYPNAM=$P(VACAT,"";"",I) Q:VATYPNAM="""" D"
1905^MAGD(2006.79,16,1,111,0)=" ...I +VATYPNAM[VATYP S VATYPNAM=$P(VATYPNAM,"":"",2),@VAV@($P(VAS,""^"",22),VATYP)=VATYP_""^""_VATYPNAM_""^""_VAACT"
1906^MAGD(2006.79,16,1,112,0)="Q3 K VABEG,VAEND,VAZIP4 Q"
1907^MAGD(2006.79,16,1,113,0)=" ;"
1908^MAGD(2006.79,16,1,114,0)="4 ;Other Address [OAD]"
1909^MAGD(2006.79,16,1,115,0)=" N VAZIP4"
1910^MAGD(2006.79,16,1,116,0)=" I $S('$D(VAOA(""A"")):1,VAOA(""A"")<1:1,VAOA(""A"")>6:1,1:0) S VAX=.21,VAOA(""A"")=7"
1911^MAGD(2006.79,16,1,117,0)=" E S VAX="".""_$P(""33^34^211^331^311^25"",""^"",+VAOA(""A""))"
1912^MAGD(2006.79,16,1,118,0)=" S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"""") I VAX(1)=.25 S VAX=$P(VAX,""^"",1)_""^^""_$P(VAX,""^"",2,99)"
1913^MAGD(2006.79,16,1,119,0)=" S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,""^"",VAX(2)))=$P(VAX,""^"",I)"
1914^MAGD(2006.79,16,1,120,0)=" S @VAV@($P(VAS,""^"",7))="""",@VAV@($P(VAS,""^"",8))=$P(VAX,""^"",9),VAX(2)=8"
1915^MAGD(2006.79,16,1,121,0)=" F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,""^"",VAX(2)))=$P(VAX,""^"",I)"
1916^MAGD(2006.79,16,1,122,0)=" I ""^.311^.25""[(""^""_VAX(1)_""^"") S @VAV@($P(VAS,""^"",10))="""""
1917^MAGD(2006.79,16,1,123,0)=" S VAZ=@VAV@($P(VAS,""^"",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),""^"",1),@VAV@($P(VAS,""^"",5))=VAZ_""^""_VAZ(1)"
1918^MAGD(2006.79,16,1,124,0)=" S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA(""A""))"
1919^MAGD(2006.79,16,1,125,0)=" S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"""",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_""-""_$E(VAZIP4,6,9))"
1920^MAGD(2006.79,16,1,126,0)=" Q"
1921^MAGD(2006.79,17,0)="VADPT2^3050311.125837"
1922^MAGD(2006.79,17,1,0)="^2006.791^60^60"
1923^MAGD(2006.79,17,1,1,0)="VADPT2 ;ALB/MJK - ESTABLISH PATIENT VARIABLES ; 3/23/88 9:13 PM ; [10/20/95 4:02pm]"
1924^MAGD(2006.79,17,1,2,0)=" ;;5.3;Registration;**69**;Aug 13, 1993"
1925^MAGD(2006.79,17,1,3,0)="5 ; -- INP call"
1926^MAGD(2006.79,17,1,4,0)=" S (VAWD,VATS,VADX,VAPP,VAAP,VARM)="""" D NOW^%DTC S VANOW=% K VAMV,VAMV0"
1927^MAGD(2006.79,17,1,5,0)=" I '$D(VAINDT) N VAINDT S VAINDT=VANOW"
1928^MAGD(2006.79,17,1,6,0)=" S VATD=9999999.999999-VAINDT"
1929^MAGD(2006.79,17,1,7,0)=" F VAID=VATD:0 S VAID=$O(^DGPM(""APID"",DFN,VAID)) Q:'VAID S VAMV=$O(^(VAID,0)) D CHK I $D(VAMV) K:""^3^4^5^""[(""^""_VAMT_""^"") VAMV,VAMV0 Q"
1930^MAGD(2006.79,17,1,8,0)=" ;"
1931^MAGD(2006.79,17,1,9,0)=" G:'$D(VAMV0) DONE"
1932^MAGD(2006.79,17,1,10,0)=" S (VAPRT,VAPRC,VACN)=1 D GET^VADPT30"
1933^MAGD(2006.79,17,1,11,0)=" S VAMV0=^DGPM(VAMV,0),VAMVT=$P(VAMV0,""^"",4),VACA=$P(VAMV0,""^"",14),VACA0=$S($D(^DGPM(+VACA,0)):^(0),1:"""")"
1934^MAGD(2006.79,17,1,12,0)=" ;"
1935^MAGD(2006.79,17,1,13,0)=" ; set: adm ifn(1) ; doctor(2) ; tr spec(3) ; ward(4) ; room(5) ; attending (11)"
1936^MAGD(2006.79,17,1,14,0)=" S @VAV@($P(VAS,""^"",1))=VACA,@VAV@($P(VAS,""^"",2))=VAPP,@VAV@($P(VAS,""^"",3))=VATS,@VAV@($P(VAS,""^"",4))=VAWD,@VAV@($P(VAS,""^"",5))=$P(VARM,""^"",2),@VAV@($P(VAS,""^"",11))=VAAP"
1937^MAGD(2006.79,17,1,15,0)=" ;"
1938^MAGD(2006.79,17,1,16,0)=" ; set bed/no bed mvt type(6)"
1939^MAGD(2006.79,17,1,17,0)=" D IB S @VAV@($P(VAS,""^"",6))=VAZ"
1940^MAGD(2006.79,17,1,18,0)=" ;"
1941^MAGD(2006.79,17,1,19,0)=" ; set adm date(7)"
1942^MAGD(2006.79,17,1,20,0)=" S Y=+VACA0 X:Y ^DD(""DD"") S @VAV@($P(VAS,""^"",7))=+VACA0_""^""_Y"
1943^MAGD(2006.79,17,1,21,0)=" ;"
1944^MAGD(2006.79,17,1,22,0)=" ; set: adm type(8) ; adm dx(9) ; ptf ifn(10)"
1945^MAGD(2006.79,17,1,23,0)=" S @VAV@($P(VAS,""^"",8))=$P(VACA0,""^"",4)_""^""_$S($D(^DG(405.1,+$P(VACA0,""^"",4),0)):$P(^(0),""^""),1:""""),@VAV@($P(VAS,""^"",9))=$P(VACA0,""^"",10),@VAV@($P(VAS,""^"",10))=$P(VACA0,""^"",16)"
1946^MAGD(2006.79,17,1,24,0)=" ;"
1947^MAGD(2006.79,17,1,25,0)="DONE K VAID,VANOW,VACA,VACA0,VAMV,VAMV0,VATD,VAMT,VAMVT D KVAR^VADPT30 Q"
1948^MAGD(2006.79,17,1,26,0)=" ;"
1949^MAGD(2006.79,17,1,27,0)="IB ;In-Bed status"
1950^MAGD(2006.79,17,1,28,0)=" ; input: VAINDT = internal date of requested info"
1951^MAGD(2006.79,17,1,29,0)=" ; VAMV = starting IFN"
1952^MAGD(2006.79,17,1,30,0)=" ; VAMV0 = 0th of VAMV"
1953^MAGD(2006.79,17,1,31,0)=" ;"
1954^MAGD(2006.79,17,1,32,0)=" ; output: VAZ = <O:not in bed OR 1: in bed>^fac. mvt name"
1955^MAGD(2006.79,17,1,33,0)=" ; VAZ(2) = abs ret date"
1956^MAGD(2006.79,17,1,34,0)=" ;"
1957^MAGD(2006.79,17,1,35,0)=" S VAZ=0,VAZ(2)="""""
1958^MAGD(2006.79,17,1,36,0)=" S VAXI=+$O(^DGPM(""APMV"",DFN,+$P(VAMV0,""^"",14),9999999.999999-VAINDT)),VAXI=+$O(^(VAXI,0))"
1959^MAGD(2006.79,17,1,37,0)=" I 'VAXI,$D(VAIP(""L"")),$P(VAMV0,""^"",2)=4 S VAXI=VAMV ; only used via IN5"
1960^MAGD(2006.79,17,1,38,0)=" G IBQ:'VAXI"
1961^MAGD(2006.79,17,1,39,0)=" S VAX0=$S($D(^DGPM(VAXI,0)):^(0),1:"""")"
1962^MAGD(2006.79,17,1,40,0)=" G IBQ:VAX0']"""",IBQ:""^3^5^""[(""^""_$P(VAX0,""^"",2)_""^"")"
1963^MAGD(2006.79,17,1,41,0)=" S VAXI=$S($D(^DG(405.1,+$P(VAX0,""^"",4),0)):$P(^(0),""^""),1:"""")"
1964^MAGD(2006.79,17,1,42,0)=" ; -- check in-bed status flag"
1965^MAGD(2006.79,17,1,43,0)=" S VAZ=$S('$D(^DG(405.2,+$P(VAX0,""^"",18),""E"")):1,1:'^(""E""))_""^""_VAXI,VAZ(2)=$P(VAX0,""^"",13)"
1966^MAGD(2006.79,17,1,44,0)="IBQ K VAXI,VAX0 Q"
1967^MAGD(2006.79,17,1,45,0)=" ;"
1968^MAGD(2006.79,17,1,46,0)="CHK ; -- check if mvt exists and if 'while asih' type d/c"
1969^MAGD(2006.79,17,1,47,0)=" ; if VAMV returned undefined then continue $Oing"
1970^MAGD(2006.79,17,1,48,0)=" ;"
1971^MAGD(2006.79,17,1,49,0)=" I $D(^DGPM(+VAMV,0)) S VAMV0=^(0),VAMT=$P(VAMV0,""^"",2)"
1972^MAGD(2006.79,17,1,50,0)=" I '$D(VAMV0) K VAMV G CHKQ"
1973^MAGD(2006.79,17,1,51,0)=" I ""^42^47^""[(""^""_$P(VAMV0,""^"",18)_""^""),$P(VAMV0,""^"",22)'=2,$O(^DGPM(""APMV"",DFN,+$P(VAMV0,""^"",14),VAID)),$O(^($O(^(VAID)),0)),$D(^DGPM($O(^(0)),0)),""^13^44^""[(""^""_$P(^(0),""^"",18)_""^"") K VAMV,VAMV0"
1974^MAGD(2006.79,17,1,52,0)=" ; info: 47 mvt can not have seq #; will always be null"
1975^MAGD(2006.79,17,1,53,0)="CHKQ Q"
1976^MAGD(2006.79,17,1,54,0)=" ;"
1977^MAGD(2006.79,17,1,55,0)="ADM ; -- send back adm ifn for dfn on vaindt or now"
1978^MAGD(2006.79,17,1,56,0)=" S VADT=$S($D(VAINDT):VAINDT,1:"""") I 'VADT D NOW^%DTC S VADT=%"
1979^MAGD(2006.79,17,1,57,0)=" S VAID=9999999.999999-VADT,VADMVT="""""
1980^MAGD(2006.79,17,1,58,0)=" F S VAID=$O(^DGPM(""ATID1"",DFN,VAID)) Q:'VAID S VAMV=+$O(^DGPM(""ATID1"",DFN,VAID,0)) I $D(^DGPM(VAMV,0)) S VAMV0=^(0),VAMV1=$S($D(^DGPM(+$P(VAMV0,""^"",17),0)):^(0),1:9999999.999999) D Q:VADMVT!($P(VAMV0,U,18)'=40)"
1981^MAGD(2006.79,17,1,59,0)=" .I VAMV0'>VADT,VAMV1>VADT S VADMVT=VAMV"
1982^MAGD(2006.79,17,1,60,0)=" K VAID,VADT,VAMV,VAMV0,VAMV1"
1983^MAGD(2006.79,18,0)="VADPT3^3050311.125837"
1984^MAGD(2006.79,18,1,0)="^2006.791^97^97"
1985^MAGD(2006.79,18,1,1,0)="VADPT3 ;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm"
1986^MAGD(2006.79,18,1,2,0)=" ;;5.3;Registration;**532**;Aug 13, 1993"
1987^MAGD(2006.79,18,1,3,0)=" ;Inpatient variables [Version 5.0 and above]"
1988^MAGD(2006.79,18,1,4,0)="6 ;"
1989^MAGD(2006.79,18,1,5,0)=" D NOW^%DTC S (NOW,VAX(""DAT""))=%,NOWI=9999999.999999-%"
1990^MAGD(2006.79,18,1,6,0)=" ;"
1991^MAGD(2006.79,18,1,7,0)=" I $D(VAIP(""E"")),$D(^DGPM(+VAIP(""E""),0)) S VAX(""DT"")=+^(0),E=+VAIP(""E"") G GO ;Specific Entry"
1992^MAGD(2006.79,18,1,8,0)=" ;"
1993^MAGD(2006.79,18,1,9,0)=" I $D(VAIP(""D"")),""^l^L^""[(""^""_$E(VAIP(""D""))_""^"") D LAST G GO:E,Q"
1994^MAGD(2006.79,18,1,10,0)=" ;"
1995^MAGD(2006.79,18,1,11,0)=" S VAX=$S($D(VAIP(""D"")):VAIP(""D""),$D(VAINDT):VAINDT,1:0)"
1996^MAGD(2006.79,18,1,12,0)=" I VAX S:VAX?7N!(VAX?7N1""."".N) VAX(""DT"")=VAX I '$D(VAX(""DT"")) G Q ;Invalid Entry"
1997^MAGD(2006.79,18,1,13,0)=" ;"
1998^MAGD(2006.79,18,1,14,0)=" S:'$D(VAX(""DT"")) VAX(""DT"")=NOW"
1999^MAGD(2006.79,18,1,15,0)=" I VAX(""DT"")=VAX(""DAT"") S E=$S($D(^DPT(DFN,.102)):+^(.102),1:0),E=$S($D(^DGPM(E,0)):E,1:0) G GO:E D LODGER G GO:E D ASIHOF G GO:E,Q ;Current IP"
2000^MAGD(2006.79,18,1,16,0)=" ;"
2001^MAGD(2006.79,18,1,17,0)=" ;Find Past Movement"
2002^MAGD(2006.79,18,1,18,0)=" S VAX=+$O(^DGPM(""APID"",DFN,9999999.999999-VAX(""DT""))) I 'VAX D LODGER G GO:E,Q"
2003^MAGD(2006.79,18,1,19,0)=" S VAX=+$O(^DGPM(""APID"",DFN,VAX,0)) I '$D(^DGPM(VAX,0)) D LODGER G GO:E,Q"
2004^MAGD(2006.79,18,1,20,0)=" S VAZ=^DGPM(VAX,0) D OK G GO:E D LODGER G GO:E,Q"
2005^MAGD(2006.79,18,1,21,0)=" ;"
2006^MAGD(2006.79,18,1,22,0)="GO S:'$D(VAX(""DT"")) VAX(""DT"")=NOW D ^VADPT31 ; setting of VAX(""DT"") can be removed??"
2007^MAGD(2006.79,18,1,23,0)=" ;"
2008^MAGD(2006.79,18,1,24,0)="Q K NOW,NOWI,VAX,VAZ,VAZ2,E,VACC,VAQ,VANN,VASET,^UTILITY(""VADPTZ"",$J,DFN) D KVAR^VADPT30 Q"
2009^MAGD(2006.79,18,1,25,0)=" ;"
2010^MAGD(2006.79,18,1,26,0)="OK N VAADT,VADDT,VAQUIT"
2011^MAGD(2006.79,18,1,27,0)=" S E=0,VAZ2=""^""_(+$P(VAZ,""^"",18))_""^"""
2012^MAGD(2006.79,18,1,28,0)=" I ""^13^41^46^""[VAZ2 D OK1 Q:'VAX G OK"
2013^MAGD(2006.79,18,1,29,0)=" I ""^42^""[VAZ2 D 42 I 'Y D OK1 Q:'VAX G OK"
2014^MAGD(2006.79,18,1,30,0)=" I ""^47^""[VAZ2 D 47 I 'Y D OK1 Q:'VAX G OK"
2015^MAGD(2006.79,18,1,31,0)=" I $D(VAX(""DT"")),$P(VAZ,""^"",2)=3,VAZ'>VAX(""DT"") Q"
2016^MAGD(2006.79,18,1,32,0)=" ;DG*5.3*532"
2017^MAGD(2006.79,18,1,33,0)=" ;Check for out-of-order disch. recs caused by same day adm./disch."
2018^MAGD(2006.79,18,1,34,0)=" ;where disch. date < adm. date because disch. date had no time"
2019^MAGD(2006.79,18,1,35,0)=" I +VAZ<2890000,$D(VAX(""DT"")),$P(VAZ,""^"",2)'=3 S VAQUIT=0 D Q:VAQUIT"
2020^MAGD(2006.79,18,1,36,0)=" .S VAADT=$P(VAZ,""^"",14) Q:'VAADT"
2021^MAGD(2006.79,18,1,37,0)=" .S VADDT=$P($G(^DGPM(VAADT,0)),""^"",17) Q:'VADDT"
2022^MAGD(2006.79,18,1,38,0)=" .S VADDT=$P($G(^DGPM(VADDT,0)),""^"",14) I $P(VADDT,""."",2)="""",VADDT=$P(VAADT,"".""),VAZ'>VAX(""DT"") S VAQUIT=1"
2023^MAGD(2006.79,18,1,39,0)=" S E=+VAX Q"
2024^MAGD(2006.79,18,1,40,0)=" ;"
2025^MAGD(2006.79,18,1,41,0)="OK1 S VAX=+$O(^DGPM(""APID"",DFN,9999999.9999999-(VAZ+($P(VAZ,""^"",22)/10000000)))),VAX=+$O(^(VAX,0))"
2026^MAGD(2006.79,18,1,42,0)=" I VAX,$D(^DGPM(VAX,0)) S VAZ=^(0)"
2027^MAGD(2006.79,18,1,43,0)=" Q"
2028^MAGD(2006.79,18,1,44,0)=" ;"
2029^MAGD(2006.79,18,1,45,0)="LAST ; returns last movement for patient"
2030^MAGD(2006.79,18,1,46,0)=" ; called by bed control and pt inquiry"
2031^MAGD(2006.79,18,1,47,0)=" S VAX=+$O(^DGPM(""APID"",DFN,NOWI)),E=0"
2032^MAGD(2006.79,18,1,48,0)=" I $D(VAIP(""L"")) D LLDCHK G LASTQ:E"
2033^MAGD(2006.79,18,1,49,0)=" S VAX=+$O(^DGPM(""APID"",DFN,VAX,0)) I $D(^DGPM(VAX,0)) S VAZ=^(0) D OK"
2034^MAGD(2006.79,18,1,50,0)="LASTQ S VAX(""DT"")=NOW"
2035^MAGD(2006.79,18,1,51,0)=" Q"
2036^MAGD(2006.79,18,1,52,0)=" ;"
2037^MAGD(2006.79,18,1,53,0)="LODGER ;"
2038^MAGD(2006.79,18,1,54,0)=" S E=0 G LODGERQ:'$D(VAIP(""L""))"
2039^MAGD(2006.79,18,1,55,0)=" I VAX(""DT"")=VAX(""DAT"") S VAX=$S($D(^DPT(DFN,.107)):^(.107),1:"""") G LODGERQ:VAX']"""" S E=$S($D(^DPT(""LD"",VAX,DFN)):+^(DFN),1:0) G LODGERQ"
2040^MAGD(2006.79,18,1,56,0)=" ;"
2041^MAGD(2006.79,18,1,57,0)=" S VAX=$O(^DGPM(""ATID4"",DFN,9999999.999999-VAX(""DT""))) S:VAX E=+$O(^DGPM(""ATID4"",DFN,VAX,0))"
2042^MAGD(2006.79,18,1,58,0)=" I E S E=$S($D(^DGPM(E,0)):E,1:0) I E,$D(^DGPM(+$P(^(0),""^"",17),0)),^(0)'>VAX(""DT"") S E=0"
2043^MAGD(2006.79,18,1,59,0)="LODGERQ Q"
2044^MAGD(2006.79,18,1,60,0)=" ;"
2045^MAGD(2006.79,18,1,61,0)="LLDCHK ; -- last lodger mvt checking ; build array of inverse dates and chk"
2046^MAGD(2006.79,18,1,62,0)=" N IDT S IDT(VAX)=0"
2047^MAGD(2006.79,18,1,63,0)=" S IDT=+$O(^DGPM(""ATID4"",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))"
2048^MAGD(2006.79,18,1,64,0)=" S IDT=+$O(^DGPM(""ATID5"",DFN,NOWI)) S:IDT IDT(IDT)=+$O(^(IDT,0))"
2049^MAGD(2006.79,18,1,65,0)=" S IDT=+$O(IDT(0)) I IDT S E=IDT(IDT),E=$S($D(^DGPM(E,0)):E,1:0)"
2050^MAGD(2006.79,18,1,66,0)=" Q"
2051^MAGD(2006.79,18,1,67,0)=" ; "
2052^MAGD(2006.79,18,1,68,0)="CHK ;"
2053^MAGD(2006.79,18,1,69,0)=" G VAR^VADPT30"
2054^MAGD(2006.79,18,1,70,0)=" ;"
2055^MAGD(2006.79,18,1,71,0)="ASIHOF ; -- is last mvt asih oth fac"
2056^MAGD(2006.79,18,1,72,0)=" S E=0,VAX=$S('$O(^DGPM(""APID"",DFN,NOWI)):"""",1:$O(^DGPM(""APID"",DFN,$O(^(NOWI)),0)))"
2057^MAGD(2006.79,18,1,73,0)=" I VAX,$D(^DGPM(VAX,0)),""^43^45^""[(""^""_$P(^(0),""^"",18)_""^"") S E=VAX"
2058^MAGD(2006.79,18,1,74,0)=" Q"
2059^MAGD(2006.79,18,1,75,0)=" ;"
2060^MAGD(2006.79,18,1,76,0)="42 ; -- check to see if this mvt can be used; for 'while asih' d/c category"
2061^MAGD(2006.79,18,1,77,0)=" ; If Y returned high then mvt is good"
2062^MAGD(2006.79,18,1,78,0)=" ;"
2063^MAGD(2006.79,18,1,79,0)=" I VAZ'<VAX(""DAT"") S Y=0 G Q42 ; not a real d/c yet"
2064^MAGD(2006.79,18,1,80,0)=" I $P(VAZ,""^"",22)=2 S Y=0 G Q42 ; nhcu d/c assoicated w/asih d/c (seq #2)"
2065^MAGD(2006.79,18,1,81,0)=" D SCAN"
2066^MAGD(2006.79,18,1,82,0)="Q42 Q"
2067^MAGD(2006.79,18,1,83,0)=" ;"
2068^MAGD(2006.79,18,1,84,0)="SCAN ; -- determine is d/c while in other fac(Y=1 returned if so.)"
2069^MAGD(2006.79,18,1,85,0)=" ;"
2070^MAGD(2006.79,18,1,86,0)=" N VAID,VACA,M S Y=0,VAID=9999999.999999-VAZ,VACA=+$P(VAZ,""^"",14)"
2071^MAGD(2006.79,18,1,87,0)=" F VAID=VAID:0 S VAID=$O(^DGPM(""APMV"",DFN,VACA,VAID)) Q:'VAID I $D(^DGPM(+$O(^(VAID,0)),0)) S M=$P(^(0),""^"",18) I ""^13^44^43^45^""[(""^""_M_""^"") S Y=$S(M=43!(M=45):1,1:0) Q"
2072^MAGD(2006.79,18,1,88,0)=" Q"
2073^MAGD(2006.79,18,1,89,0)=" ;"
2074^MAGD(2006.79,18,1,90,0)="47 ; -- check to see if d/c from nhcu while asih in other fac"
2075^MAGD(2006.79,18,1,91,0)=" ; If y returned high then mvt is good."
2076^MAGD(2006.79,18,1,92,0)=" D SCAN Q"
2077^MAGD(2006.79,18,1,93,0)=" ;"
2078^MAGD(2006.79,18,1,94,0)=" ; 13 = to asih (vah) (xfr)|44 = resume asih in parent facility (xfr)"
2079^MAGD(2006.79,18,1,95,0)=" ; 41 = from asih (d/c)|45 = change asih location(other fac)(xfr)"
2080^MAGD(2006.79,18,1,96,0)=" ; 42 = while asih (d/c)|46 = continues asih (other fac) (d/c)"
2081^MAGD(2006.79,18,1,97,0)=" ; 43 = to asih(other fac)(xfr)|47 = discharge from nhcu while asih (d/c)"
2082^MAGD(2006.79,19,0)="VADPT30^3050311.125837"
2083^MAGD(2006.79,19,1,0)="^2006.791^80^80"
2084^MAGD(2006.79,19,1,1,0)="VADPT30 ;ALB/MJK - Current Inpatient Variables; 12 DEC 1988"
2085^MAGD(2006.79,19,1,2,0)=" ;;5.3;Registration;**111,498,509**;Aug 13, 1993"
2086^MAGD(2006.79,19,1,3,0)=" ;"
2087^MAGD(2006.79,19,1,4,0)="VAR ; -- inpatient demographics variables"
2088^MAGD(2006.79,19,1,5,0)=" ; input: DFN, VATD = inverse date ; VACN ="
2089^MAGD(2006.79,19,1,6,0)=" ; VAPRC = ; VAPRT ="
2090^MAGD(2006.79,19,1,7,0)=" ;"
2091^MAGD(2006.79,19,1,8,0)=" ; output: VAWD = ward ; VATS = tr. spec. ; VARM = room/bed"
2092^MAGD(2006.79,19,1,9,0)=" ; VAPP = doc ; VADX = diagnosis ; VAMV = mv entry"
2093^MAGD(2006.79,19,1,10,0)=" ; VAAP = attending physician"
2094^MAGD(2006.79,19,1,11,0)=" ; VAFD = answer to facility directory question"
2095^MAGD(2006.79,19,1,12,0)=" ;"
2096^MAGD(2006.79,19,1,13,0)=" S (VAWDA,VAWD,VATS,VAMV,VARM,VAPP,VAAP,VADX,VAFD)="""",VAID=VATD"
2097^MAGD(2006.79,19,1,14,0)=" ; -- get mv"
2098^MAGD(2006.79,19,1,15,0)=" D MV G VARQ:VAMV0']"""""
2099^MAGD(2006.79,19,1,16,0)=" S Y=$G(^DGPM(+$P(VAMV0,""^"",14),0)) I $P(Y,""^"",2)=1 D"
2100^MAGD(2006.79,19,1,17,0)=" .N DCD"
2101^MAGD(2006.79,19,1,18,0)=" .S DCD=+$P(Y,""^"",17) I DCD S DCD=+$G(^DGPM(DCD,0))"
2102^MAGD(2006.79,19,1,19,0)=" .S Y=$G(^DGPM(+$P(VAMV0,""^"",14),""DIR""))"
2103^MAGD(2006.79,19,1,20,0)=" .S Y=$P(Y,""^"",1)"
2104^MAGD(2006.79,19,1,21,0)=" .I Y="""" S Y=$S('DCD:1,(DCD<3030414.999999):"""",1:1) Q:Y="""""
2105^MAGD(2006.79,19,1,22,0)=" .S VAFD=Y_""^""_$$EXTERNAL^DILFD(405,41,,Y)"
2106^MAGD(2006.79,19,1,23,0)=" ; quit if not an adm or xfr"
2107^MAGD(2006.79,19,1,24,0)=" I ""^1^2^""'[(""^""_$P(VAMV0,""^"",2)_""^"") G VARQ"
2108^MAGD(2006.79,19,1,25,0)=" I 'VAPRC,""^2^3^13^25^26^43^44^45^""[(""^""_VAMT_""^"") G VARQ"
2109^MAGD(2006.79,19,1,26,0)=" I VAPRC,""^13^43^44^45^""[(""^""_VAMT_""^"") G VARQ"
2110^MAGD(2006.79,19,1,27,0)=" S:VAPRC VABO=$S(VAMT<4:VAMT,1:4) D GET"
2111^MAGD(2006.79,19,1,28,0)=" ;I 'VACN,'VATS S VATS=TSD ;what is this"
2112^MAGD(2006.79,19,1,29,0)="VARQ K VAMV0,VAMT,VAID"
2113^MAGD(2006.79,19,1,30,0)=" Q"
2114^MAGD(2006.79,19,1,31,0)=" ;"
2115^MAGD(2006.79,19,1,32,0)="GET ; -- get variables and quit when all set(Y=1)"
2116^MAGD(2006.79,19,1,33,0)=" S VACA=+$P(VAMV0,""^"",14)"
2117^MAGD(2006.79,19,1,34,0)=" D TS,SET G GETQ:Y"
2118^MAGD(2006.79,19,1,35,0)=" F VAID=VATD:0 S VAID=$O(^DGPM(""APMV"",DFN,VACA,VAID)) Q:'VAID F VAIFN=0:0 S VAIFN=$O(^DGPM(""APMV"",DFN,VACA,VAID,VAIFN)) Q:'VAIFN I $D(^DGPM(VAIFN,0)) S VAMV0=^(0) D SET G GETQ:Y"
2119^MAGD(2006.79,19,1,36,0)="GETQ K VACA,VAIFN,VAID Q"
2120^MAGD(2006.79,19,1,37,0)=" ;"
2121^MAGD(2006.79,19,1,38,0)="KVAR K VAMV,VAWDA,VAWD,VARM,VAPP,VAAP,VATS,VATD,VAPRC,VAPRT,VACN,VADX,VABO,VAFD Q"
2122^MAGD(2006.79,19,1,39,0)=" ;"
2123^MAGD(2006.79,19,1,40,0)="SET ; -- set variables if null"
2124^MAGD(2006.79,19,1,41,0)=" S Y=0"
2125^MAGD(2006.79,19,1,42,0)=" I 'VAWD,$D(^DIC(42,+$P(VAMV0,""^"",6),0)) S VAWDA=$S($D(VAIFN):VAIFN,1:VAMV),VAWD=$P(VAMV0,""^"",6)_""^""_$P(^(0),""^"") S VARM="""" I $D(^DG(405.4,+$P(VAMV0,""^"",7),0)) S VARM=$P(VAMV0,""^"",7)_""^""_$P(^(0),""^"")"
2126^MAGD(2006.79,19,1,43,0)=" I 'VACN,VAWD S Y=1"
2127^MAGD(2006.79,19,1,44,0)=" N VARSTR"
2128^MAGD(2006.79,19,1,45,0)=" S VARSTR=""^^^^^VAWD^VARM^VAPP^VATS^VADX^^^^^^^^^VAAP^"""
2129^MAGD(2006.79,19,1,46,0)=" S $P(VARSTR,""^"",41)=""VAFD"""
2130^MAGD(2006.79,19,1,47,0)=" I VACN,'VAPRT,$D(DGPMDDF),@$P(VARSTR,""^"",+DGPMDDF),VAMV S Y=1"
2131^MAGD(2006.79,19,1,48,0)=" I VACN,VAPRT,VAWD,VAMV,VADX]"""" S Y=1"
2132^MAGD(2006.79,19,1,49,0)=" Q"
2133^MAGD(2006.79,19,1,50,0)=" ;"
2134^MAGD(2006.79,19,1,51,0)="TS ; set VADX, VATS, VAAP, and VAPP via VACA x-refs"
2135^MAGD(2006.79,19,1,52,0)=" N VAMV0"
2136^MAGD(2006.79,19,1,53,0)=" S:$D(^DGPM(VACA,0)) VADX=$P(^(0),""^"",10)"
2137^MAGD(2006.79,19,1,54,0)=" F VAID=VATD:0 S VAID=$O(^DGPM(""ATS"",DFN,VACA,VAID)) Q:'VAID F VAT=0:0 S VAT=$O(^DGPM(""ATS"",DFN,VACA,VAID,VAT)) Q:'VAT F VAIFN=0:0 S VAIFN=$O(^DGPM(""ATS"",DFN,VACA,VAID,VAT,VAIFN)) Q:'VAIFN D TS1 G TSQ:VAPP&VATS&VAAP"
2138^MAGD(2006.79,19,1,55,0)="TSQ K VAIFN,VAT Q"
2139^MAGD(2006.79,19,1,56,0)=" ;"
2140^MAGD(2006.79,19,1,57,0)="TS1 ; set VATS, VAPP, and VAAP"
2141^MAGD(2006.79,19,1,58,0)=" Q:'$D(^DGPM(VAIFN,0)) S VAMV0=^(0)"
2142^MAGD(2006.79,19,1,59,0)=" I 'VAPP,$D(^VA(200,+$P(VAMV0,""^"",8),0)) S Y=$P(VAMV0,""^"",8)_""^""_$P(^(0),""^"") S VAPP=Y"
2143^MAGD(2006.79,19,1,60,0)=" I 'VAAP,$D(^VA(200,+$P(VAMV0,""^"",19),0)) S Y=$P(VAMV0,""^"",19)_""^""_$P(^(0),""^"") S VAAP=Y"
2144^MAGD(2006.79,19,1,61,0)=" I 'VATS,$D(^DIC(45.7,+$P(VAMV0,""^"",9),0)) S VATS=$P(VAMV0,""^"",9)_""^""_$P(^(0),""^"")"
2145^MAGD(2006.79,19,1,62,0)=" Q"
2146^MAGD(2006.79,19,1,63,0)=" ;"
2147^MAGD(2006.79,19,1,64,0)="MV ; -- get latest mv for pt before VAID and not ASIH mv"
2148^MAGD(2006.79,19,1,65,0)=" S (VAMV,VAMV0)="""""
2149^MAGD(2006.79,19,1,66,0)=" F VAID=VAID:0 S VAID=$O(^DGPM(""APID"",DFN,VAID)) G MVQ:'VAID S VAMV=$O(^DGPM(""APID"",DFN,VAID,0)) I $D(^DGPM(+VAMV,0)) S VAMT=$P(^(0),""^"",18) G MVQ:'VAMT Q:""^13^41^42^47^""'[(""^""_VAMT_""^"")"
2150^MAGD(2006.79,19,1,67,0)=" S VAMV0=^DGPM(VAMV,0)"
2151^MAGD(2006.79,19,1,68,0)="MVQ Q"
2152^MAGD(2006.79,19,1,69,0)=" ;"
2153^MAGD(2006.79,19,1,70,0)="A ;return current admission or last admission for patient"
2154^MAGD(2006.79,19,1,71,0)=" S Y=$S($D(^DPT(DFN,.105)):+^(.105),1:0) G AQ:$D(^DGPM(Y,0))"
2155^MAGD(2006.79,19,1,72,0)=" N VAID,VAMV,VAMV0"
2156^MAGD(2006.79,19,1,73,0)=" F VAID=0:0 S VAID=$O(^DGPM(""ATID1"",DFN,VAID)) Q:'VAID F VAMV=0:0 S VAMV=$O(^DGPM(""ATID1"",DFN,VAID,VAMV)) Q:'VAMV I $D(^DGPM(VAMV,0)) S VAMV0=^(0) D DIS G AQ:Y"
2157^MAGD(2006.79,19,1,74,0)=" S Y=0"
2158^MAGD(2006.79,19,1,75,0)="AQ Q"
2159^MAGD(2006.79,19,1,76,0)=" ;"
2160^MAGD(2006.79,19,1,77,0)="DIS ; check for ASIH discharges"
2161^MAGD(2006.79,19,1,78,0)=" S Y=$S('$D(^DGPM(+$P(VAMV0,""^"",17),0)):VAMV,""^41^46""[(U_$P(^(0),""^"",18)_U):0,1:VAMV)"
2162^MAGD(2006.79,19,1,79,0)=" Q"
2163^MAGD(2006.79,19,1,80,0)=" ;"
2164^MAGD(2006.79,20,0)="VADPT31^3050311.125837"
2165^MAGD(2006.79,20,1,0)="^2006.791^76^76"
2166^MAGD(2006.79,20,1,1,0)="VADPT31 ;ALB/MRL/MJK - PATIENT VARIABLES [IN5], CONT.; 12 DEC 1988"
2167^MAGD(2006.79,20,1,2,0)=" ;;5.3;Registration;**498,509**;Aug 13, 1993"
2168^MAGD(2006.79,20,1,3,0)=" ;Inpatient variables [Version 5.0 and above]"
2169^MAGD(2006.79,20,1,4,0)="EN N VAINDT,VAMV,VAMV0"
2170^MAGD(2006.79,20,1,5,0)=" S VAMV=+E,VAMV0=^DGPM(VAMV,0),VAX(""CA"")=+$P(VAMV0,""^"",14) G ENQ:'$D(^DGPM(+VAX(""CA""),0))"
2171^MAGD(2006.79,20,1,6,0)=" I $D(VAIP(""M"")) D CE G ENQ:'$D(^DGPM(+E,0)) S VAMV=+E,VAMV0=^(0)"
2172^MAGD(2006.79,20,1,7,0)=" S @VAV@($P(VAS,""^"",1))=E"
2173^MAGD(2006.79,20,1,8,0)=" S Y=$P(VAMV0,""^"",2),@VAV@($P(VAS,""^"",2))=Y_""^""_$S($D(^DG(405.3,+Y,0)):$P(^(0),""^""),1:"""")"
2174^MAGD(2006.79,20,1,9,0)=" S Y=$S(+VAMV0:+VAMV0,1:"""") X:Y ^DD(""DD"") S @VAV@($P(VAS,""^"",3))=+VAMV0_""^""_Y"
2175^MAGD(2006.79,20,1,10,0)=" S Y=$P(VAMV0,""^"",18),@VAV@($P(VAS,""^"",4))=Y_""^""_$S($D(^DG(405.2,+Y,0)):$P(^(0),""^""),1:"""")"
2176^MAGD(2006.79,20,1,11,0)=" S Y=+$P(^DGPM(VAX(""CA""),0),""^"",16) S:Y @VAV@($P(VAS,""^"",12))=Y"
2177^MAGD(2006.79,20,1,12,0)=" ;"
2178^MAGD(2006.79,20,1,13,0)=" S VATD=VAX(""DT"") D FIND"
2179^MAGD(2006.79,20,1,14,0)=" S @VAV@($P(VAS,""^"",5))=VAWD,@VAV@($P(VAS,""^"",6))=VARM,@VAV@($P(VAS,""^"",7))=VAPP,@VAV@($P(VAS,""^"",8))=VATS,@VAV@($P(VAS,""^"",9))=VADX,@VAV@($P(VAS,""^"",18))=VAAP"
2180^MAGD(2006.79,20,1,15,0)=" ;"
2181^MAGD(2006.79,20,1,16,0)=" S VANODE=$G(^DGPM(VAX(""CA""),0)) I $P(VANODE,""^"",2)=1 D"
2182^MAGD(2006.79,20,1,17,0)=" .N DCD"
2183^MAGD(2006.79,20,1,18,0)=" .S DCD=+$P(VANODE,""^"",17) I DCD S DCD=+$G(^DGPM(DCD,0))"
2184^MAGD(2006.79,20,1,19,0)=" .S VANODE=$G(^DGPM(VAX(""CA""),""DIR""))"
2185^MAGD(2006.79,20,1,20,0)=" .S Y=$P(VANODE,""^"",1)"
2186^MAGD(2006.79,20,1,21,0)=" .I Y="""" S Y=$S('DCD:1,(DCD<3030414.999999):"""",1:1) Q:Y="""""
2187^MAGD(2006.79,20,1,22,0)=" .S @VAV@($P(VAS,""^"",19),1)=Y_""^""_$$EXTERNAL^DILFD(405,41,,Y)"
2188^MAGD(2006.79,20,1,23,0)=" .S Y=$P(VANODE,""^"",2) S @VAV@($P(VAS,""^"",19),2)=Y_""^""_$$EXTERNAL^DILFD(405,42,,Y)"
2189^MAGD(2006.79,20,1,24,0)=" .S Y=$P(VANODE,""^"",3) S @VAV@($P(VAS,""^"",19),3)=Y_""^""_$$EXTERNAL^DILFD(405,43,,Y)"
2190^MAGD(2006.79,20,1,25,0)=" ;"
2191^MAGD(2006.79,20,1,26,0)=" S VAINDT=+VAMV0 D IB^VADPT2 S @VAV@($P(VAS,""^"",10))=+VAZ"
2192^MAGD(2006.79,20,1,27,0)=" I 'VAZ,$D(VAZ(2)),VAZ(2)?7N!(VAZ(2)?7N1""."".N) S Y=VAZ(2) X ^DD(""DD"") S @VAV@($P(VAS,""^"",11))=VAZ(2)_""^""_Y"
2193^MAGD(2006.79,20,1,28,0)=" ;"
2194^MAGD(2006.79,20,1,29,0)=" I $D(VAIP(""M"")) S VASET=$S(VAIP(""M""):14,1:13),VASET(VASET)="""",VANODE=$P(VAS,""^"",VASET) D COPY ; last or adm"
2195^MAGD(2006.79,20,1,30,0)=" I '$D(VAIP(""M"")),$D(VAIP(""D"")),""^l^L^""[(""^""_$E(VAIP(""D""))_""^"") S VASET(14)="""",VANODE=$P(VAS,""^"",14) D COPY ; last"
2196^MAGD(2006.79,20,1,31,0)=" I ""^3^5^""[(""^""_$P(VAMV0,""^"",2)_""^"") S VASET(17)="""",VANODE=$P(VAS,""^"",17) D COPY ; d/c"
2197^MAGD(2006.79,20,1,32,0)=" I '$D(VASET(13)) S VAMV=VAX(""CA""),VAMV0=^DGPM(VAMV,0),VANODE=$P(VAS,""^"",13) D STORE ; adm"
2198^MAGD(2006.79,20,1,33,0)=" D BLD^VADPT32 G ENQ:'$D(^UTILITY(""VADPTZ"",$J,DFN))"
2199^MAGD(2006.79,20,1,34,0)=" S VAXE=$S($D(^UTILITY(""VADPTZ"",$J,DFN,1)):^(1),1:""""),VAMV0=$P(VAXE,""||"",2),VAMV=+VAXE"
2200^MAGD(2006.79,20,1,35,0)=" I VAMV,""^3^5^""[(""^""_$P(VAMV0,""^"",2)_""^""),'$D(VASET(17)) S VANODE=$P(VAS,""^"",17) D STORE ; d/c"
2201^MAGD(2006.79,20,1,36,0)=" I VAMV,'$D(VASET(14)) S VANODE=$P(VAS,""^"",14) D STORE ;last"
2202^MAGD(2006.79,20,1,37,0)=" I $S('VANN:1,'$D(^UTILITY(""VADPTZ"",$J,DFN,+VANN)):1,1:0) G ENQ"
2203^MAGD(2006.79,20,1,38,0)=" I $D(^UTILITY(""VADPTZ"",$J,DFN,VANN-1)) S VAXE=^(VANN-1),VAMV=+VAXE,VAMV0=$P(VAXE,""||"",2) I VAMV S VANODE=$P(VAS,""^"",16) D STORE ; following"
2204^MAGD(2006.79,20,1,39,0)=" I $D(^UTILITY(""VADPTZ"",$J,DFN,VANN+1)) S VAXE=^(VANN+1),VAMV=+VAXE,VAMV0=$P(VAXE,""||"",2) I VAMV S VANODE=$P(VAS,""^"",15) D STORE ; prior"
2205^MAGD(2006.79,20,1,40,0)=" ;"
2206^MAGD(2006.79,20,1,41,0)="ENQ K VAMVX,VANODE,VAMCC,VAXE,VANN D KVAR^VADPT30 Q"
2207^MAGD(2006.79,20,1,42,0)=" ;"
2208^MAGD(2006.79,20,1,43,0)="FIND ;"
2209^MAGD(2006.79,20,1,44,0)=" S VAMVX=VAMV,VAMV0X=VAMV0"
2210^MAGD(2006.79,20,1,45,0)=" S (VAWD,VATS,VAMV,VARM,VAPP,VAAP,VADX)="""""
2211^MAGD(2006.79,20,1,46,0)=" I $P(VAMV0,""^"",2)=4!($P(VAMV0,""^"",2)=5) D LODGER G FINDQ"
2212^MAGD(2006.79,20,1,47,0)=" S VATD=9999999.999999-VATD,(VACN,VAPRC,VAPRT)=1 D GET^VADPT30"
2213^MAGD(2006.79,20,1,48,0)="FINDQ S VAMV=VAMVX,VAMV0=VAMV0X K VAMVX,VAMV0X"
2214^MAGD(2006.79,20,1,49,0)=" Q"
2215^MAGD(2006.79,20,1,50,0)=" ;"
2216^MAGD(2006.79,20,1,51,0)="CE I 'VAIP(""M"") S E=+VAX(""CA"") Q"
2217^MAGD(2006.79,20,1,52,0)=" S E=$O(^DGPM(""APMV"",DFN,+VAX(""CA""),0)) Q:E'>0 S E=$O(^DGPM(""APMV"",DFN,+VAX(""CA""),E,0)) Q"
2218^MAGD(2006.79,20,1,53,0)=" ;"
2219^MAGD(2006.79,20,1,54,0)="STORE ; store 'other nodes'"
2220^MAGD(2006.79,20,1,55,0)=" S @VAV@(VANODE)=+VAMV"
2221^MAGD(2006.79,20,1,56,0)=" S Y=+VAMV0 X:Y ^DD(""DD"") S @VAV@(VANODE,1)=+VAMV0_""^""_Y"
2222^MAGD(2006.79,20,1,57,0)=" S Y=$P(VAMV0,""^"",2),@VAV@(VANODE,2)=Y_""^""_$S($D(^DG(405.3,+Y,0)):$P(^(0),""^""),1:"""")"
2223^MAGD(2006.79,20,1,58,0)=" S Y=$P(VAMV0,""^"",18),@VAV@(VANODE,3)=Y_""^""_$S($D(^DG(405.2,+Y,0)):$P(^(0),""^""),1:"""")"
2224^MAGD(2006.79,20,1,59,0)=" S VATD=+VAMV0 D FIND"
2225^MAGD(2006.79,20,1,60,0)=" S @VAV@(VANODE,4)=VAWD,@VAV@(VANODE,5)=VAPP,@VAV@(VANODE,6)=VATS,@VAV@(VANODE,7)=VADX"
2226^MAGD(2006.79,20,1,61,0)=" Q"
2227^MAGD(2006.79,20,1,62,0)=" ;"
2228^MAGD(2006.79,20,1,63,0)="COPY ; copy from primary to other nodes"
2229^MAGD(2006.79,20,1,64,0)=" S @VAV@(VANODE)=VAMV"
2230^MAGD(2006.79,20,1,65,0)=" ; 1-mvt d/t ; 2-transaction type ; 3-mvt type"
2231^MAGD(2006.79,20,1,66,0)=" S @VAV@(VANODE,1)=@VAV@($P(VAS,""^"",3)),@VAV@(VANODE,2)=@VAV@($P(VAS,""^"",2)),@VAV@(VANODE,3)=@VAV@($P(VAS,""^"",4))"
2232^MAGD(2006.79,20,1,67,0)=" ; 4-ward ; 5-doc ; 6-treat spec ; 7-dx"
2233^MAGD(2006.79,20,1,68,0)=" S @VAV@(VANODE,4)=@VAV@($P(VAS,""^"",5)),@VAV@(VANODE,5)=@VAV@($P(VAS,""^"",7)),@VAV@(VANODE,6)=@VAV@($P(VAS,""^"",8)),@VAV@(VANODE,7)=@VAV@($P(VAS,""^"",9))"
2234^MAGD(2006.79,20,1,69,0)=" Q"
2235^MAGD(2006.79,20,1,70,0)=" ;"
2236^MAGD(2006.79,20,1,71,0)="LODGER ; -- get lodger data"
2237^MAGD(2006.79,20,1,72,0)=" S VAWD=$S($P(VAMV0,""^"",2)=4:$P(VAMV0,""^"",6),$D(^DGPM(+$P(VAMV0,""^"",14),0)):$P(^(0),""^"",6),1:"""")"
2238^MAGD(2006.79,20,1,73,0)=" S VAWD=$S($D(^DIC(42,+VAWD,0)):VAWD_""^""_$P(^(0),""^""),1:"""")"
2239^MAGD(2006.79,20,1,74,0)=" S VARM=$S($P(VAMV0,""^"",2)=4:$P(VAMV0,""^"",7),$D(^DGPM(+$P(VAMV0,""^"",14),0)):$P(^(0),""^"",7),1:"""")"
2240^MAGD(2006.79,20,1,75,0)=" S VARM=$S($D(^DG(405.4,+VARM,0)):VARM_""^""_$P(^(0),""^""),1:"""")"
2241^MAGD(2006.79,20,1,76,0)=" Q"
2242^MAGD(2006.79,21,0)="VADPT32^3050311.125837"
2243^MAGD(2006.79,21,1,0)="^2006.791^19^19"
2244^MAGD(2006.79,21,1,1,0)="VADPT32 ;ALB/MRL/MJK - PATIENT VARIABLES [IN5], CONT.; 12 DEC 1988"
2245^MAGD(2006.79,21,1,2,0)=" ;;5.3;Registration;;Aug 13, 1993"
2246^MAGD(2006.79,21,1,3,0)=" ;Inpatient variables [Version 5.0 and above]"
2247^MAGD(2006.79,21,1,4,0)=" ;"
2248^MAGD(2006.79,21,1,5,0)="BLD ; build array of mvt in reverse order up one before E mvt"
2249^MAGD(2006.79,21,1,6,0)=" K ^UTILITY(""VADPTZ"",$J,DFN) S (VANN,VAQ,VAZ,VACC)=0"
2250^MAGD(2006.79,21,1,7,0)=" I ""^4^5^""[(""^""_$P(VAMV0,""^"",2)_""^"") D LODGER G BLDQ"
2251^MAGD(2006.79,21,1,8,0)=" F I=0:0 S VAZ=$O(^DGPM(""APMV"",DFN,VAX(""CA""),VAZ)),VAZ(1)=0 Q:VAQ!(VAZ'>0) F I1=0:0 S VAZ(1)=$O(^DGPM(""APMV"",DFN,VAX(""CA""),VAZ,VAZ(1))) Q:VAQ!(VAZ(1)'>0) S VACC=VACC+1 D BA"
2252^MAGD(2006.79,21,1,9,0)="BLDQ K VACC,VAQ,VAZ Q"
2253^MAGD(2006.79,21,1,10,0)=" ;"
2254^MAGD(2006.79,21,1,11,0)="BA ;Build Movement Array"
2255^MAGD(2006.79,21,1,12,0)=" I VANN,VACC=(VANN+2) S VAQ=1 Q"
2256^MAGD(2006.79,21,1,13,0)=" S:VAZ(1)=+E VANN=VACC S X=$S($D(^DGPM(+VAZ(1),0)):^(0),1:""""),^UTILITY(""VADPTZ"",$J,DFN,VACC)=VAZ(1)_""||""_X Q"
2257^MAGD(2006.79,21,1,14,0)=" ;"
2258^MAGD(2006.79,21,1,15,0)="LODGER ;"
2259^MAGD(2006.79,21,1,16,0)=" S VANN=1,X=^DGPM(E,0)"
2260^MAGD(2006.79,21,1,17,0)=" I $P(X,""^"",2)=5 S ^UTILITY(""VADPTZ"",$J,DFN,1)=E_""||""_X S:$D(^DGPM(+$P(X,""^"",14),0)) ^UTILITY(""VADPTZ"",$J,DFN,2)=+$P(X,""^"",14)_""||""_^(0)"
2261^MAGD(2006.79,21,1,18,0)=" I $P(X,""^"",2)=4 S:$D(^DGPM(+$P(X,""^"",17),0)) ^UTILITY(""VADPTZ"",$J,DFN,1)=+$P(X,""^"",17)_""||""_^(0),VANN=2 S ^UTILITY(""VADPTZ"",$J,DFN,VANN)=E_""||""_X"
2262^MAGD(2006.79,21,1,19,0)=" Q"
2263^MAGD(2006.79,22,0)="VADPT4^3050311.125837"
2264^MAGD(2006.79,22,1,0)="^2006.791^58^58"
2265^MAGD(2006.79,22,1,1,0)="VADPT4 ;ALB/MRL/MJK - PATIENT VARIABLES; 12 DEC 1988"
2266^MAGD(2006.79,22,1,2,0)=" ;;5.3;Registration;**343,342,528**;Aug 13, 1993"
2267^MAGD(2006.79,22,1,3,0)="7 ;Eligibility [ELIG]"
2268^MAGD(2006.79,22,1,4,0)=" F I=.15,.3,.31,.32,.36,.361,""INE"",""TYPE"",""VET"" S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"""")"
2269^MAGD(2006.79,22,1,5,0)=" S VAZ=$P(VAX(.36),""^"",1) S:$D(^DIC(8,+VAZ,0)) VAZ=VAZ_""^""_$P(^(0),""^"",1) S @VAV@($P(VAS,""^"",1))=VAZ"
2270^MAGD(2006.79,22,1,6,0)=" S VAX=0 F I=0:0 S VAX=$O(^DPT(DFN,""E"",VAX)) Q:VAX'>0 S VAZ=VAX I $D(^DIC(8,+VAZ,0)),+@VAV@($P(VAS,""^""))'=VAZ S VAZ=VAZ_""^""_$P(^DIC(8,+VAZ,0),""^"") S @VAV@($P(VAS,""^"",1),VAX)=VAZ"
2271^MAGD(2006.79,22,1,7,0)=" S VAZ=$P(VAX(.32),""^"",3) S:$D(^DIC(21,+VAZ,0)) VAZ=VAZ_""^""_$P(^(0),""^"",1) S @VAV@($P(VAS,""^"",2))=VAZ"
2272^MAGD(2006.79,22,1,8,0)=" S VAZ=$S($P(VAX(.3),""^"",1)=""Y"":1,1:0) S:VAZ VAZ=VAZ_""^""_$P(VAX(.3),""^"",2) S @VAV@($P(VAS,""^"",3))=VAZ"
2273^MAGD(2006.79,22,1,9,0)=" S @VAV@($P(VAS,""^"",4))=$S(VAX(""VET"")=""Y"":1,1:0),VAZ=$S(+$P(VAX(.15),""^"",2):0,1:1),@VAV@($P(VAS,""^"",5))=VAZ"
2274^MAGD(2006.79,22,1,10,0)=" I VAZ F I=1:1:6 S @VAV@($P(VAS,""^"",5),I)="""" G 71"
2275^MAGD(2006.79,22,1,11,0)=" S VAZ=$P(VAX(.15),""^"",2),Y=VAZ X ^DD(""DD"") S @VAV@($P(VAS,""^"",5),1)=VAZ_""^""_Y,VAZ=$P(VAX(""INE""),""^"",1) S:VAZ]"""" VAZ=VAZ_""^""_$P(""VAMC^REGIONAL OFFICE^RPC"",""^"",VAZ) S @VAV@($P(VAS,""^"",5),2)=VAZ"
2276^MAGD(2006.79,22,1,12,0)=" S @VAV@($P(VAS,""^"",5),3)=$P(VAX(""INE""),""^"",3),VAZ=$P(VAX(""INE""),""^"",4) S:$D(^DIC(5,+VAZ,0)) VAZ=VAZ_""^""_$P(^(0),""^"",1) S @VAV@($P(VAS,""^"",5),4)=VAZ"
2277^MAGD(2006.79,22,1,13,0)=" S @VAV@($P(VAS,""^"",5),5)=$P(VAX(""INE""),""^"",6),@VAV@($P(VAS,""^"",5),6)=$P(VAX(.3),""^"",7)"
2278^MAGD(2006.79,22,1,14,0)="71 S VAZ=VAX(""TYPE"") S:$D(^DG(391,+VAZ,0)) VAZ=VAZ_""^""_$P(^(0),""^"",1) S @VAV@($P(VAS,""^"",6))=VAZ"
2279^MAGD(2006.79,22,1,15,0)=" S @VAV@($P(VAS,""^"",7))=$P(VAX(.31),""^"",3),VAZ=$P(VAX(.361),""^"",1) S:VAZ]"""" VAZ=VAZ_""^""_$S(VAZ=""V"":""VERIFIED"",VAZ=""P"":""PENDING VERIFICATION"",VAZ=""R"":""PENDING RE-VERIFICATION"",1:"""") S @VAV@($P(VAS,""^"",8))=VAZ"
2280^MAGD(2006.79,22,1,16,0)=" I $D(^DPT(DFN,0)) S VAX=$P(^(0),""^"",14),VAX=$G(^DG(408.32,+VAX,0)) I VAX]"""" S @VAV@($P(VAS,""^"",9))=$P(VAX,""^"",2)_""^""_$P(VAX,""^"",1)"
2281^MAGD(2006.79,22,1,17,0)=" Q"
2282^MAGD(2006.79,22,1,18,0)=" ;"
2283^MAGD(2006.79,22,1,19,0)="8 ;Monetary Benefits [MB]"
2284^MAGD(2006.79,22,1,20,0)=" N DGTOTVA"
2285^MAGD(2006.79,22,1,21,0)=" S @VAV@($P(VAS,""^"",6))=0 ; SSI no longer supported"
2286^MAGD(2006.79,22,1,22,0)=" D ALL^DGMTU21(DFN,""V"",DT,""I"")"
2287^MAGD(2006.79,22,1,23,0)=" S VAX=$G(^DGMT(408.21,+$G(DGINC(""V"")),0)) F I=8,11,13 S @VAV@($S(I=8:$P(VAS,""^"",3),I=11:$P(VAS,""^"",5),1:$P(VAS,""^"",8)))=$S($P(VAX,""^"",I)'="""":""1^""_$P(VAX,""^"",I),1:0)"
2288^MAGD(2006.79,22,1,24,0)=" S VAX=$G(^DPT(DFN,.362))"
2289^MAGD(2006.79,22,1,25,0)=" S DGTOTVA=$P(VAX,U,20)"
2290^MAGD(2006.79,22,1,26,0)=" F I=12,13,14 S @VAV@($S(I=12:$P(VAS,""^"",1),(I=13):$P(VAS,""^"",2),1:$P(VAS,""^"",4)))=$S($P(VAX,""^"",I)=""Y"":1_U_DGTOTVA,1:0)"
2291^MAGD(2006.79,22,1,27,0)=" S I=17 S @VAV@($P(VAS,""^"",9))=$S($P(VAX,""^"",17)=""Y"":1_U_$P(VAX,U,6),1:0)"
2292^MAGD(2006.79,22,1,28,0)=" S VAX=$G(^DPT(DFN,.3)) S @VAV@($P(VAS,""^"",7))=$S($P(VAX,""^"",11)=""Y"":1_U_DGTOTVA,1:0)"
2293^MAGD(2006.79,22,1,29,0)=" K DGDEP,DGREL,DGINC,DGINR Q"
2294^MAGD(2006.79,22,1,30,0)=" ;"
2295^MAGD(2006.79,22,1,31,0)="9 ;Service information"
2296^MAGD(2006.79,22,1,32,0)=" F I=.32,.321,.52,.53 S VAX(I)=$S($D(^DPT(DFN,I)):^(I),1:"""")"
2297^MAGD(2006.79,22,1,33,0)=" S VAX(""N"")=.321 F I=1,2,3 S VAX(3)=I,VAZ=$S($P(VAX(.321),""^"",I)=""Y"":1,1:0),@VAV@($P(VAS,""^"",VAX(3)))=VAZ I VAZ S VAX(1)=$S(I=1:""4^5"",I=2:""7^9^8"",1:11),VAX(4)=0 D 91"
2298^MAGD(2006.79,22,1,34,0)=" S VAX(""N"")=.52 F I=5,11 S VAX(3)=$S(I=5:4,1:5),VAX(1)=$S(I=5:""7^8"",1:""13^14""),VAZ=$S($P(VAX(.52),""^"",I)=""Y"":1,1:0),@VAV@($P(VAS,""^"",VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91"
2299^MAGD(2006.79,22,1,35,0)=" S VAX(3)=10,VAX(1)=""15"",VAZ=$S($P(VAX(.52),U,15)]"""":1,1:0),@VAV@($P(VAS,U,VAX(3)))=VAZ I VAZ S VAX(4)=0 D 91"
2300^MAGD(2006.79,22,1,36,0)=" F I=6,7,8 S @VAV@($P(VAS,""^"",I))="""" F VAX(1)=1:1:5 S @VAV@($P(VAS,""^"",I),VAX(1))="""""
2301^MAGD(2006.79,22,1,37,0)=" S VAX(""N"")=.32,VAZ=$S($P(VAX(.32),""^"",5)]"""":1,1:0),@VAV@($P(VAS,""^"",6))=VAZ I VAZ,$P(VAX(.32),""^"",19)=""Y"" S VAZ=1,@VAV@($P(VAS,""^"",7))=VAZ I VAZ,$P(VAX(.32),""^"",20)=""Y"" S @VAV@($P(VAS,""^"",8))=1"
2302^MAGD(2006.79,22,1,38,0)=" F I=6,7,8 I @VAV@($P(VAS,""^"",I)) S VAX(3)=I,VAX(1)=$S(I=6:""6^7"",I=7:""11^12"",1:""16^17""),VAX(4)=3 D 91"
2303^MAGD(2006.79,22,1,39,0)=" S VAX(""N"")=.53,VAX(3)=9,VAX(1)=""2^3"",VAZ=$S($P(VAX(.53),U)=""Y"":1,$P(VAX(.53),U)=""N"":1,1:0),@VAV@($P(VAS,U,VAX(3)))=$S($P(VAX(.53),U)=""Y"":1,$P(VAX(.53),U)=""N"":0,1:"""") I VAZ S VAX(4)=0 D 93"
2304^MAGD(2006.79,22,1,40,0)=" Q"
2305^MAGD(2006.79,22,1,41,0)=" ;"
2306^MAGD(2006.79,22,1,42,0)="91 F VAX(2)=1:1 S VAX(4)=VAX(4)+1,X=+$P(VAX(1),""^"",VAX(2)) Q:'X S X=$P(VAX(VAX(""N"")),""^"",X),VAZ=X,Y=VAZ X:Y]"""" ^DD(""DD"") S @VAV@($P(VAS,""^"",VAX(3)),VAX(4))=$S(VAZ]"""":VAZ_""^""_Y,1:"""")"
2307^MAGD(2006.79,22,1,43,0)=" Q:VAX(3)=1!(VAX(3)=9)!(VAX(3)=10)"
2308^MAGD(2006.79,22,1,44,0)=" I VAX(3)=2 S @VAV@($P(VAS,""^"",2),4)=$P(VAX(.321),""^"",10) S (X,VAZ)=$P(VAX(.321),""^"",13) S:X]"""" VAZ=VAZ_""^""_$S(X=""K"":""KOREAN DMZ"",1:""VIETNAM"") S @VAV@($P(VAS,""^"",2),5)=VAZ Q"
2309^MAGD(2006.79,22,1,45,0)=" I VAX(3)<4 S X=$P(VAX(.321),""^"",12),VAZ=X S:X]"""" VAZ=VAZ_""^""_$S(X=""T"":""NUCLEAR TESTING"",X=""N"":""NAGASAKI/HIROSHIMA"",1:""BOTH"") S @VAV@($P(VAS,""^"",3),2)=VAZ Q"
2310^MAGD(2006.79,22,1,46,0)=" I VAX(3)<6 S X=$P(VAX(VAX(""N"")),""^"",$S(VAX(3)=4:6,1:12)),VAZ=X S:$D(^DIC(22,+X,0)) VAZ=VAZ_""^""_$P(^(0),""^"",1) S @VAV@($P(VAS,""^"",VAX(3)),3)=VAZ Q"
2311^MAGD(2006.79,22,1,47,0)=" S X=$S(VAX(3)=6:5,VAX(3)=7:10,1:15),VAX(2)=0 F VAX(5)=X,X+3,X-1 S VAX(2)=VAX(2)+1,VAZ=$P(VAX(VAX(""N"")),""^"",VAX(5)),@VAV@($P(VAS,""^"",VAX(3)),VAX(2))=VAZ I ""^4^5^9^10^14^15^""[(""^""_VAX(5)_""^""),+VAZ D 92"
2312^MAGD(2006.79,22,1,48,0)=" Q"
2313^MAGD(2006.79,22,1,49,0)="92 S VAX(6)=""^DIC(""_$S('(VAX(5)#5):23,1:25)_"",""_+VAZ_"",0)"" I $D(@(VAX(6))) S VAZ=$P(^(0),""^"",1),@VAV@($P(VAS,""^"",VAX(3)),VAX(2))=@VAV@($P(VAS,""^"",VAX(3)),VAX(2))_""^""_VAZ"
2314^MAGD(2006.79,22,1,50,0)=" Q"
2315^MAGD(2006.79,22,1,51,0)="93 ;"
2316^MAGD(2006.79,22,1,52,0)=" NEW VAFILE,VAIENS,VAFLDS,VAARR,VAI"
2317^MAGD(2006.79,22,1,53,0)=" S VAFILE=2,VAIENS=DFN_"","",VAFLDS="".532;.533"""
2318^MAGD(2006.79,22,1,54,0)=" D GETS^DIQ(VAFILE,VAIENS,VAFLDS,""IEN"",""VAARR"")"
2319^MAGD(2006.79,22,1,55,0)=" F VAI=1:1 S VAFLDS(VAI)=$P(VAFLDS,"";"",VAI) Q:VAFLDS(VAI)="""" D"
2320^MAGD(2006.79,22,1,56,0)=" . I '$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),""I"")),'$D(VAARR(VAFILE,VAIENS,VAFLDS(VAI),""E"")) S @VAV@($P(VAS,""^"",VAX(3)),VAI)="""""
2321^MAGD(2006.79,22,1,57,0)=" . E S @VAV@($P(VAS,U,VAX(3)),VAI)=$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),""I""))_""^""_$G(VAARR(VAFILE,VAIENS,VAFLDS(VAI),""E""))"
2322^MAGD(2006.79,22,1,58,0)=" Q"
2323^MAGD(2006.79,23,0)="VADPT5^3050311.125837"
2324^MAGD(2006.79,23,1,0)="^2006.791^103^103"
2325^MAGD(2006.79,23,1,1,0)="VADPT5 ;ALB/MRL/MJK - PATIENT VARIABLES [REG]; 14 DEC 1988 ; 8/6/04 7:42am"
2326^MAGD(2006.79,23,1,2,0)=" ;;5.3;Registration;**54,63,242,584**;Aug 13, 1993"
2327^MAGD(2006.79,23,1,3,0)="10 ;Registration/Disposition [REG]"
2328^MAGD(2006.79,23,1,4,0)=" N VARPSV"
2329^MAGD(2006.79,23,1,5,0)=" S VARPSV(""C"")=$S('$G(VARP(""C"")):999999999,1:+VARP(""C""))"
2330^MAGD(2006.79,23,1,6,0)=" S VARPSV(""F"")=9999999-$S($G(VARP(""F""))?7N.E:VARP(""F""),1:0)"
2331^MAGD(2006.79,23,1,7,0)=" S VARPSV(""T"")=$S($G(VARP(""T""))?7N.E:VARP(""T""),1:7777777) I '$P(VARPSV(""T""),""."",2) S $P(VARPSV(""T""),""."",2)=999999"
2332^MAGD(2006.79,23,1,8,0)=" S VARPSV(""T"")=9999999-VARPSV(""T"")"
2333^MAGD(2006.79,23,1,9,0)=" S VAX=VARPSV(""T""),VAX(1)=0"
2334^MAGD(2006.79,23,1,10,0)=" I '$D(^DPT(DFN,""DIS"")) Q"
2335^MAGD(2006.79,23,1,11,0)=" F I=0:0 S VAX=$O(^DPT(DFN,""DIS"",VAX)) Q:VAX=""""!(VAX>VARPSV(""F""))!(VAX(1)+1>VARPSV(""C"")) S VAX(2)=$G(^DPT(DFN,""DIS"",VAX,0)),VAX(1)=VAX(1)+1 D 101:+VAX(2)>0"
2336^MAGD(2006.79,23,1,12,0)=" Q"
2337^MAGD(2006.79,23,1,13,0)="101 S (VAX(""I""),VAX(""E""))="""",VAX(3)=0 F I=1,2,3,4,5,6,7,9 S VAX(3)=VAX(3)+1,$P(VAX(""I""),""^"",VAX(3))=$P(VAX(2),""^"",I) D 102"
2338^MAGD(2006.79,23,1,14,0)=" S @VAV@(VAX(1),""I"")=VAX(""I""),@VAV@(VAX(1),""E"")=VAX(""E"") Q"
2339^MAGD(2006.79,23,1,15,0)="102 I ""^1^6^""[(""^""_VAX(3)_""^"") S Y=$P(VAX(""I""),""^"",VAX(3)) I Y]"""" X ^DD(""DD"") S $P(VAX(""E""),""^"",VAX(3))=Y Q"
2340^MAGD(2006.79,23,1,16,0)=" S X(1)=$S($D(^DD(2.101,$S(I<9:(I-1),1:I),0)):$P(^(0),""^"",3),1:"""") I ""^2^3^""[(""^""_VAX(3)_""^""),$P(VAX(""I""),""^"",VAX(3))]"""",X(1)]"""" S $P(VAX(""E""),""^"",VAX(3))=$P($P(X(1),$P(VAX(""I""),""^"",VAX(3))_"":"",2),"";"",1) Q"
2341^MAGD(2006.79,23,1,17,0)=" I ""^4^5^7^8^""[(""^""_VAX(3)_""^""),$P(VAX(""I""),""^"",VAX(3))]"""",X(1)]"""" S X(1)=""^""_X(1)_$P(VAX(""I""),""^"",VAX(3))_"",0)"" I $D(@(X(1))) S $P(VAX(""E""),""^"",VAX(3))=$P(^(0),""^"",1)"
2342^MAGD(2006.79,23,1,18,0)=" Q"
2343^MAGD(2006.79,23,1,19,0)=" ;"
2344^MAGD(2006.79,23,1,20,0)="11 ;Clinic Enrollments [SDE]"
2345^MAGD(2006.79,23,1,21,0)=" S (VAX,VAX(1))=0 F I=0:0 S VAX=$O(^DPT(DFN,""DE"",VAX)) Q:VAX'>0 S VAZ=$S($D(^DPT(DFN,""DE"",VAX,0)):^(0),1:"""") I +VAZ,$P(VAZ,""^"",2)'=""I"" S VAX(3)=0 D 111"
2346^MAGD(2006.79,23,1,22,0)=" Q"
2347^MAGD(2006.79,23,1,23,0)="111 S VAX(4)=0 F I1=0:0 S VAX(4)=$O(^DPT(DFN,""DE"",VAX,1,VAX(4))) Q:VAX(4)'>0!(VAX(3)) S VAZ(1)=$S($D(^DPT(DFN,""DE"",VAX,1,VAX(4),0)):^(0),1:"""") I +VAZ(1),$P(VAZ(1),""^"",3)']"""" S VAX(3)=VAZ(1)"
2348^MAGD(2006.79,23,1,24,0)=" Q:'VAX(3) S (VAX(""I""),VAX(""E""))="""",Y=+VAX(3),$P(VAX(""I""),""^"",2)=Y X ^DD(""DD"") S $P(VAX(""E""),""^"",2)=Y"
2349^MAGD(2006.79,23,1,25,0)=" S $P(VAX(""I""),""^"",3)=$P(VAX(3),""^"",2) I $P(VAX(""I""),""^"",3)]"""" S $P(VAX(""E""),""^"",3)=$S($P(VAX(""I""),""^"",3)=""O"":""OPT"",$P(VAX(""I""),""^"",3)=""A"":""AC"",1:"""")"
2350^MAGD(2006.79,23,1,26,0)=" S $P(VAX(""I""),""^"",1)=+VAZ,$P(VAX(""E""),""^"",1)=$S($D(^SC(+VAZ,0)):$P(^(0),""^"",1),1:""""),VAX(1)=VAX(1)+1,@VAV@(VAX(1),""I"")=VAX(""I""),@VAV@(VAX(1),""E"")=VAX(""E"") Q"
2351^MAGD(2006.79,23,1,27,0)=" ;"
2352^MAGD(2006.79,23,1,28,0)="12 ;Appointments [SDA]"
2353^MAGD(2006.79,23,1,29,0)=" N VASDSV,SDCNT,SDARRAY"
2354^MAGD(2006.79,23,1,30,0)=" D NOW^%DTC"
2355^MAGD(2006.79,23,1,31,0)=" S VASDSV(""F"")=$S($G(VASD(""F""))?7N.E:VASD(""F""),1:%)"
2356^MAGD(2006.79,23,1,32,0)=" S VASDSV(""T"")=$S(+$G(VASD(""T"")):+VASD(""T""),1:9999999) I '$P(VASDSV(""T""),""."",2) S $P(VASDSV(""T""),""."",2)=999999"
2357^MAGD(2006.79,23,1,33,0)=" S VASDSV(""W"")=$S('$G(VASD(""W"")):12,1:VASD(""W""))"
2358^MAGD(2006.79,23,1,34,0)=" S VAZ(2)=$S($D(VASD(""N"")):VASD(""N""),1:9999)"
2359^MAGD(2006.79,23,1,35,0)=" ;Set STATUS Codes (VistA;RSA)"
2360^MAGD(2006.79,23,1,36,0)=" S VAZ="";R^I;I^N;NS^NA;NSR^C;CC^CA;CCR^PC;CP^PCA;CPR^NT;NT^"",VAZ(1)="""""
2361^MAGD(2006.79,23,1,37,0)=" ;Extract User Required STATUS Codes in RSA format"
2362^MAGD(2006.79,23,1,38,0)=" F I=1:1 S I1=+$E(VASDSV(""W""),I) Q:'I1 D"
2363^MAGD(2006.79,23,1,39,0)=" .S VAZ(1)=VAZ(1)_$P($P(VAZ,""^"",I1),"";"",2)_"";"""
2364^MAGD(2006.79,23,1,40,0)=" ;Create parameter list for the extrinsic call to the Appointment API"
2365^MAGD(2006.79,23,1,41,0)=" ;Note: Appointment API can only accept a maximum of 3 fields "
2366^MAGD(2006.79,23,1,42,0)=" ; to filter on."
2367^MAGD(2006.79,23,1,43,0)=" ; 1 : ""FROM;TO"" Appointment Date Range to Search"
2368^MAGD(2006.79,23,1,44,0)=" ; 2 : Clinic IEN or Array of Clinic IENs if defined (Pass the Root)"
2369^MAGD(2006.79,23,1,45,0)=" ; 3 : Requested STATUS Codes (Passed if VASD(""C"") is not defined.)"
2370^MAGD(2006.79,23,1,46,0)=" ; 4 : Patient IEN"
2371^MAGD(2006.79,23,1,47,0)=" S SDARRAY="""",SDARRAY(1)=VASDSV(""F"")_"";""_VASDSV(""T"")"
2372^MAGD(2006.79,23,1,48,0)=" I $O(VASD(""C"",0))>0 S SDARRAY(2)=""VASD(""""C"""","""
2373^MAGD(2006.79,23,1,49,0)=" E S SDARRAY(3)=VAZ(1)"
2374^MAGD(2006.79,23,1,50,0)=" S SDARRAY(4)=DFN"
2375^MAGD(2006.79,23,1,51,0)=" ;Set Fields for API to Return"
2376^MAGD(2006.79,23,1,52,0)=" ; 1 : Appointment Date/Time"
2377^MAGD(2006.79,23,1,53,0)=" ; 2 : Clinic"
2378^MAGD(2006.79,23,1,54,0)=" ; 3 : Appointment Status"
2379^MAGD(2006.79,23,1,55,0)=" ; 10 : Appointment Type"
2380^MAGD(2006.79,23,1,56,0)=" S SDARRAY(""FLDS"")=""1;2;3;10"""
2381^MAGD(2006.79,23,1,57,0)=" ;Remove Clinic IEN from Global Reference"
2382^MAGD(2006.79,23,1,58,0)=" S SDARRAY(""SORT"")=""P"""
2383^MAGD(2006.79,23,1,59,0)=" ;Call Appointment API (Pass Array by reference)"
2384^MAGD(2006.79,23,1,60,0)=" S SDCNT=$$SDAPI^SDAMA301(.SDARRAY)"
2385^MAGD(2006.79,23,1,61,0)=" S VAX="""",VAX(1)=0"
2386^MAGD(2006.79,23,1,62,0)=" ;If error returned, determine error and set VAERR appropriately"
2387^MAGD(2006.79,23,1,63,0)=" ; 1 : For any error other than 101"
2388^MAGD(2006.79,23,1,64,0)=" ; 2 : If error is 101 : Database is unavailable "
2389^MAGD(2006.79,23,1,65,0)=" I SDCNT<0 S VAX=$O(^TMP($J,""SDAMA301"",VAX)) S VAERR=$S(VAX=101:2,1:1) K ^TMP($J,""SDAMA301"") Q"
2390^MAGD(2006.79,23,1,66,0)=" D 122:SDCNT>0"
2391^MAGD(2006.79,23,1,67,0)=" Q"
2392^MAGD(2006.79,23,1,68,0)="121 S VAX(5)=1 I VASDSV(""W"")'[1,$P(VAZ,""^"",2)']"""" S VAX(5)=0 Q"
2393^MAGD(2006.79,23,1,69,0)=" I VASDSV(""C""),'$D(VASD(""C"",+VAZ)) S VAX(5)=0 Q"
2394^MAGD(2006.79,23,1,70,0)=" S (VAX(""I""),VAX(""E""))="""",VAX(2)=1,$P(VAX(""I""),""^"",1)=+VAX F I1=1,2,16 S VAX(2)=VAX(2)+1,$P(VAX(""I""),""^"",VAX(2))=$P(VAZ,""^"",I1)"
2395^MAGD(2006.79,23,1,71,0)=" Q"
2396^MAGD(2006.79,23,1,72,0)="122 ;Build Internal/External Output Globals"
2397^MAGD(2006.79,23,1,73,0)=" ;"
2398^MAGD(2006.79,23,1,74,0)=" N SDCIEN,SDDTM,SDNODE"
2399^MAGD(2006.79,23,1,75,0)=" S (SDCIEN,SDDTM)="""""
2400^MAGD(2006.79,23,1,76,0)=" ;Redefine VAZ (STATUS Codes(RSA;VistA))"
2401^MAGD(2006.79,23,1,77,0)=" S VAZ=""R;^I;I^NS;N^NSR;NA^CC;C^CCR;CA^CP;PC^CPR;PCA^NT;NT^"""
2402^MAGD(2006.79,23,1,78,0)=" S SDDTM="""""
2403^MAGD(2006.79,23,1,79,0)=" ;Loop through appointments and convert for output"
2404^MAGD(2006.79,23,1,80,0)=" F S SDDTM=$O(^TMP($J,""SDAMA301"",DFN,SDDTM)) Q:'SDDTM D "
2405^MAGD(2006.79,23,1,81,0)=" .;Get Appointment Information and clear VAX(""I"") & VAX(""E"")"
2406^MAGD(2006.79,23,1,82,0)=" .S SDNODE=^(SDDTM),(VAX(""I""),VAX(""E""))="""""
2407^MAGD(2006.79,23,1,83,0)=" .;If Clinics were passed to appointment API,"
2408^MAGD(2006.79,23,1,84,0)=" .; Filter on Appointment Status Codes"
2409^MAGD(2006.79,23,1,85,0)=" .I $O(VASD(""C"",0))>0,(VAZ(1)'[($P($P(SDNODE,""^"",3),"";"")_"";"")) Q"
2410^MAGD(2006.79,23,1,86,0)=" .;Extract and format Appointment Date/Time"
2411^MAGD(2006.79,23,1,87,0)=" .S Y=$P(SDNODE,""^"",1)"
2412^MAGD(2006.79,23,1,88,0)=" .S $P(VAX(""I""),""^"",1)=Y"
2413^MAGD(2006.79,23,1,89,0)=" .X ^DD(""DD"") S $P(VAX(""E""),""^"",1)=Y"
2414^MAGD(2006.79,23,1,90,0)=" .;Extract and format Clinic Information"
2415^MAGD(2006.79,23,1,91,0)=" .S $P(VAX(""I""),""^"",2)=$P($P(SDNODE,""^"",2),"";"",1)"
2416^MAGD(2006.79,23,1,92,0)=" .S $P(VAX(""E""),""^"",2)=$P($P(SDNODE,""^"",2),"";"",2)"
2417^MAGD(2006.79,23,1,93,0)=" .;Extract and format Appointment Type"
2418^MAGD(2006.79,23,1,94,0)=" .S $P(VAX(""I""),""^"",4)=$P($P(SDNODE,""^"",10),"";"",1)"
2419^MAGD(2006.79,23,1,95,0)=" .S $P(VAX(""E""),""^"",4)=$P($P(SDNODE,""^"",10),"";"",2)"
2420^MAGD(2006.79,23,1,96,0)=" .;Extract and format Appointment Status"
2421^MAGD(2006.79,23,1,97,0)=" .S Y=$P($P(VAZ,$P($P(SDNODE,""^"",3),"";"")_"";"",2),""^""),$P(VAX(""I""),""^"",3)=Y"
2422^MAGD(2006.79,23,1,98,0)=" .I Y]"""" S X=$S($D(^DD(2.98,3,0)):$P(^(0),""^"",3),1:""""),$P(VAX(""E""),""^"",3)=$P($P(X,Y_"":"",2),"";"",1)"
2423^MAGD(2006.79,23,1,99,0)=" .S VAX(1)=VAX(1)+1"
2424^MAGD(2006.79,23,1,100,0)=" .;Store information in global"
2425^MAGD(2006.79,23,1,101,0)=" .S @VAV@(VAX(1),""I"")=VAX(""I""),@VAV@(VAX(1),""E"")=VAX(""E"")"
2426^MAGD(2006.79,23,1,102,0)=" K ^TMP($J,""SDAMA301"")"
2427^MAGD(2006.79,23,1,103,0)=" Q"
2428^MAGD(2006.79,24,0)="VADPT6^3050311.125837"
2429^MAGD(2006.79,24,1,0)="^2006.791^73^73"
2430^MAGD(2006.79,24,1,1,0)="VADPT6 ;ALB/MJK - PATIENT ID VARIABLES ; 12 AUG 89 @1200"
2431^MAGD(2006.79,24,1,2,0)=" ;;5.3;Registration;;Aug 13, 1993"
2432^MAGD(2006.79,24,1,3,0)=" ;"
2433^MAGD(2006.79,24,1,4,0)="PID ;"
2434^MAGD(2006.79,24,1,5,0)="13 ; -- Returns the patient id variables for DFN patient"
2435^MAGD(2006.79,24,1,6,0)=" ; usually VA(""PID"")=123-45-6789 and VA(""BID"")=""6789"""
2436^MAGD(2006.79,24,1,7,0)=" ; for VA patients."
2437^MAGD(2006.79,24,1,8,0)=" ;"
2438^MAGD(2006.79,24,1,9,0)=" ; -- Returns patient id variables as defined for the requested"
2439^MAGD(2006.79,24,1,10,0)=" ; patient eligibility for DFN patient. The variable VAPTYP should"
2440^MAGD(2006.79,24,1,11,0)=" ; contain the internal number of the desired patient eligibility."
2441^MAGD(2006.79,24,1,12,0)=" ;"
2442^MAGD(2006.79,24,1,13,0)=" ; If the VAPTYP eligibility does not exist, then the standard"
2443^MAGD(2006.79,24,1,14,0)=" ; values, as defined above, will be passed back."
2444^MAGD(2006.79,24,1,15,0)=" ;"
2445^MAGD(2006.79,24,1,16,0)=" N X,L,B K VAERR S (L,B)="""""
2446^MAGD(2006.79,24,1,17,0)=" ; L = long id ; B = brief or short id"
2447^MAGD(2006.79,24,1,18,0)=" S VAERR=$S('$D(DFN)#2:1,'$D(^DPT(+DFN,0)):1,1:0) I VAERR G PIDQ"
2448^MAGD(2006.79,24,1,19,0)=" I $D(VAPTYP),$D(^DPT(DFN,""E"",+VAPTYP,0)) S X=^(0),L=$P(X,""^"",3),B=$P(X,""^"",4)"
2449^MAGD(2006.79,24,1,20,0)=" ; -- set default id's"
2450^MAGD(2006.79,24,1,21,0)=" I L="""",$D(^DPT(DFN,.36)) S X=^(.36) I +X S L=$P(X,""^"",3),B=$P(X,""^"",4)"
2451^MAGD(2006.79,24,1,22,0)=" I L="""" S X=$P(^DPT(DFN,0),""^"",9) I X]"""" S L=$E(X,1,3)_""-""_$E(X,4,5)_""-""_$E(X,6,10),B=$E(X,6,10)"
2452^MAGD(2006.79,24,1,23,0)=" ;"
2453^MAGD(2006.79,24,1,24,0)="PIDQ S VA(""PID"")=L,VA(""BID"")=B Q"
2454^MAGD(2006.79,24,1,25,0)=" ;"
2455^MAGD(2006.79,24,1,26,0)="SET ;-- execute id format specific long id, short id and x-ref set logic"
2456^MAGD(2006.79,24,1,27,0)=" ; input: VADFN == DFN"
2457^MAGD(2006.79,24,1,28,0)=" ;"
2458^MAGD(2006.79,24,1,29,0)=" Q:'$D(^DPT(VADFN,""E"",0))"
2459^MAGD(2006.79,24,1,30,0)=" N X,DA S DA(1)=VADFN"
2460^MAGD(2006.79,24,1,31,0)=" F DA=0:0 S DA=$O(^DPT(DA(1),""E"",DA)) Q:'DA I $D(^(DA,0)) D SET1"
2461^MAGD(2006.79,24,1,32,0)=" K X,DA"
2462^MAGD(2006.79,24,1,33,0)=" Q"
2463^MAGD(2006.79,24,1,34,0)="SET1 ;"
2464^MAGD(2006.79,24,1,35,0)=" D CHK G SET1Q:'VAFMT"
2465^MAGD(2006.79,24,1,36,0)=" ; -- calc/store long id"
2466^MAGD(2006.79,24,1,37,0)=" S X="""""
2467^MAGD(2006.79,24,1,38,0)=" I $D(^DIC(8.2,VAFMT,""LONG"")) X ^(""LONG"") S $P(^DPT(DA(1),""E"",DA,0),U,3)=X"
2468^MAGD(2006.79,24,1,39,0)=" ; -- long id x-refs (set logic)"
2469^MAGD(2006.79,24,1,40,0)=" S VAX=X G SET1Q:X="""""
2470^MAGD(2006.79,24,1,41,0)=" F VAIX=0:0 S VAIX=$O(^DD(2.0361,.03,1,VAIX)) Q:'VAIX X ^(VAIX,1) S X=VAX"
2471^MAGD(2006.79,24,1,42,0)=" ; -- short id x-refs (set logic)"
2472^MAGD(2006.79,24,1,43,0)=" S (VAX,X)=$P(^DPT(DA(1),""E"",DA,0),U,4) G SET1Q:X="""""
2473^MAGD(2006.79,24,1,44,0)=" F VAIX=0:0 S VAIX=$O(^DD(2.0361,.04,1,VAIX)) Q:'VAIX X ^(VAIX,1) S X=VAX"
2474^MAGD(2006.79,24,1,45,0)="SET1Q K VAIX,VAX,X,VAFMT"
2475^MAGD(2006.79,24,1,46,0)=" Q"
2476^MAGD(2006.79,24,1,47,0)=" ;"
2477^MAGD(2006.79,24,1,48,0)="KILL ; -- execute id format specific x-ref kill logic"
2478^MAGD(2006.79,24,1,49,0)=" ; input: VADFN ==> DFN"
2479^MAGD(2006.79,24,1,50,0)=" ;"
2480^MAGD(2006.79,24,1,51,0)=" Q:'$D(^DPT(VADFN,""E"",0))"
2481^MAGD(2006.79,24,1,52,0)=" N X,DA S DA(1)=VADFN"
2482^MAGD(2006.79,24,1,53,0)=" F DA=0:0 S DA=$O(^DPT(DA(1),""E"",DA)) Q:'DA I $D(^(DA,0)) D KILL1"
2483^MAGD(2006.79,24,1,54,0)=" K X,DA"
2484^MAGD(2006.79,24,1,55,0)=" Q"
2485^MAGD(2006.79,24,1,56,0)=" ;"
2486^MAGD(2006.79,24,1,57,0)="KILL1 ;"
2487^MAGD(2006.79,24,1,58,0)=" D CHK G KILL1Q:'VAFMT"
2488^MAGD(2006.79,24,1,59,0)=" ; -- short id x-ref (kill logic)"
2489^MAGD(2006.79,24,1,60,0)=" S (VAX,X)=$P(^DPT(DA(1),""E"",DA,0),U,4) G KILL2:X="""""
2490^MAGD(2006.79,24,1,61,0)=" F VAIX=0:0 S VAIX=$O(^DD(2.0361,.04,1,VAIX)) Q:'VAIX X ^(VAIX,2) S X=VAX"
2491^MAGD(2006.79,24,1,62,0)=" S $P(^DPT(DA(1),""E"",DA,0),U,4)="""""
2492^MAGD(2006.79,24,1,63,0)="KILL2 ; -- long id (kill logic)"
2493^MAGD(2006.79,24,1,64,0)=" S (VAX,X)=$P(^DPT(DA(1),""E"",DA,0),U,3) G KILL1Q:X="""""
2494^MAGD(2006.79,24,1,65,0)=" F VAIX=0:0 S VAIX=$O(^DD(2.0361,.03,1,VAIX)) Q:'VAIX X ^(VAIX,2) S X=VAX"
2495^MAGD(2006.79,24,1,66,0)=" S $P(^DPT(DA(1),""E"",DA,0),U,3)="""""
2496^MAGD(2006.79,24,1,67,0)="KILL1Q K VAX,VAIX,VAFMT"
2497^MAGD(2006.79,24,1,68,0)=" Q"
2498^MAGD(2006.79,24,1,69,0)=" ;"
2499^MAGD(2006.79,24,1,70,0)="CHK ; -- ok to proceed ; fmt defined"
2500^MAGD(2006.79,24,1,71,0)=" S VAFMT=0"
2501^MAGD(2006.79,24,1,72,0)=" I $D(^DIC(8,DA,0)) S VAFMT=+$P(^(0),U,10),VAFMT=$S($D(^DIC(8.2,VAFMT,0)):VAFMT,1:0)"
2502^MAGD(2006.79,24,1,73,0)=" Q"
2503^MAGD(2006.79,25,0)="VADPT60^3050311.125837"
2504^MAGD(2006.79,25,1,0)="^2006.791^100^100"
2505^MAGD(2006.79,25,1,1,0)="VADPT60 ;ALB/MJK - Patient ID Utilities; 12 AUG 89 @1200"
2506^MAGD(2006.79,25,1,2,0)=" ;;5.3;Registration;;Aug 13, 1993"
2507^MAGD(2006.79,25,1,3,0)=" ;"
2508^MAGD(2006.79,25,1,4,0)="EN D DT^DICRW S X=""VADPT60"",DIK=""^DOPT(""""""_X_"""""","""
2509^MAGD(2006.79,25,1,5,0)=" G:$D(^DOPT(X,7)) A S ^DOPT(X,0)=""Patient ID Utilities^1N^"""
2510^MAGD(2006.79,25,1,6,0)=" F I=1:1 S Y=$T(@I) Q:Y="""" S ^DOPT(X,I,0)=$P(Y,"";"",3,99)"
2511^MAGD(2006.79,25,1,7,0)=" D IXALL^DIK"
2512^MAGD(2006.79,25,1,8,0)="A ;"
2513^MAGD(2006.79,25,1,9,0)=" W !! S DIC=""^DOPT(""""VADPT60"""","",DIC(0)=""IQEAM"" D ^DIC Q:Y<0 D @+Y G A"
2514^MAGD(2006.79,25,1,10,0)=" ;"
2515^MAGD(2006.79,25,1,11,0)="1 ;;ID Format Enter/Edit"
2516^MAGD(2006.79,25,1,12,0)=" G 1^VADPT61"
2517^MAGD(2006.79,25,1,13,0)=" ;"
2518^MAGD(2006.79,25,1,14,0)="2 ;;Eligibility Code Enter/Edit"
2519^MAGD(2006.79,25,1,15,0)=" G 2^VADPT61"
2520^MAGD(2006.79,25,1,16,0)=" ;"
2521^MAGD(2006.79,25,1,17,0)="3 ;;Specific ID Format Reset (All Patients)"
2522^MAGD(2006.79,25,1,18,0)=" W ! S DIC=""^DIC(8.2,"",DIC(0)=""AEMQZ"" D ^DIC K DIC G Q3:+Y<1 S VAFMT=+Y"
2523^MAGD(2006.79,25,1,19,0)=" S X=Y(0) D WARN^VADPT61"
2524^MAGD(2006.79,25,1,20,0)="31 W !!,""Are you sure"" S %=2 D YN^DICN"
2525^MAGD(2006.79,25,1,21,0)=" I '% W !?5,""Answer 'YES' if you wish to reset id's for all patients with"",!?5,""this format."" G 31"
2526^MAGD(2006.79,25,1,22,0)=" G 3:%'=1"
2527^MAGD(2006.79,25,1,23,0)=" S VAOPT=3 D TASK^VADPT61 G Q3"
2528^MAGD(2006.79,25,1,24,0)="QUE3 ; -- determine which elig use format"
2529^MAGD(2006.79,25,1,25,0)=" D BEG^VADPT61"
2530^MAGD(2006.79,25,1,26,0)=" K VAELG F VAELG=0:0 S VAELG=$O(^DIC(8,""AF"",VAFMT,VAELG)) Q:'VAELG S VAELG(VAELG)="""""
2531^MAGD(2006.79,25,1,27,0)=" ; -- find pt's and reset"
2532^MAGD(2006.79,25,1,28,0)=" F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN F VAELG=0:0 S VAELG=$O(^DPT(DFN,""E"",VAELG)) Q:'VAELG I $D(VAELG(VAELG)),$D(^(VAELG,0)) D IX"
2533^MAGD(2006.79,25,1,29,0)=" D END^VADPT61"
2534^MAGD(2006.79,25,1,30,0)="Q3 K DFN,VAELG,VAFMT Q"
2535^MAGD(2006.79,25,1,31,0)=" ;"
2536^MAGD(2006.79,25,1,32,0)="4 ;;Primary Eligibility ID Reset (All Patients)"
2537^MAGD(2006.79,25,1,33,0)=" W !!,""Are you sure"" S %=2 D YN^DICN"
2538^MAGD(2006.79,25,1,34,0)=" I '% W !?5,""Answer 'YES' if you wish to set or reset the patient id for"",!?5,""the id format associated with EACH patient's primary eligibility."" G 4"
2539^MAGD(2006.79,25,1,35,0)=" G Q4:%'=1"
2540^MAGD(2006.79,25,1,36,0)="41 S VAOPT=4 D TASK^VADPT61 G Q4"
2541^MAGD(2006.79,25,1,37,0)="QUE4 K VALL D BEG^VADPT61,ALL,END^VADPT61"
2542^MAGD(2006.79,25,1,38,0)="Q4 Q"
2543^MAGD(2006.79,25,1,39,0)=" ;"
2544^MAGD(2006.79,25,1,40,0)="5 ;;Specific Eligibility ID Reset (All Patients)"
2545^MAGD(2006.79,25,1,41,0)=" W ! S DIC=""^DIC(8,"",DIC(0)=""AEMQZ"" D ^DIC K DIC G Q5:+Y<1 S VAELG=+Y"
2546^MAGD(2006.79,25,1,42,0)=" I '$D(^DIC(8.2,+$P(Y(0),U,10),0)) W !!?5,*7,""No id format specified for this eligibility."" G Q5"
2547^MAGD(2006.79,25,1,43,0)=" S X=^(0) D WARN^VADPT61"
2548^MAGD(2006.79,25,1,44,0)="51 W !!,""Are you sure"" S %=2 D YN^DICN"
2549^MAGD(2006.79,25,1,45,0)=" I '% W !?5,""Answer 'YES' if you wish to reset id's for all patients with"",!?5,""this ELIGIBILITY."" G 51"
2550^MAGD(2006.79,25,1,46,0)=" G 5:%'=1"
2551^MAGD(2006.79,25,1,47,0)=" S VAOPT=5 D TASK^VADPT61 G Q5"
2552^MAGD(2006.79,25,1,48,0)="QUE5 D BEG^VADPT61"
2553^MAGD(2006.79,25,1,49,0)=" F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN I $D(^DPT(DFN,""E"",VAELG,0)) D IX"
2554^MAGD(2006.79,25,1,50,0)=" D END^VADPT61"
2555^MAGD(2006.79,25,1,51,0)="Q5 K VAELG,DFN Q"
2556^MAGD(2006.79,25,1,52,0)=" ;"
2557^MAGD(2006.79,25,1,53,0)="6 ;;Reset ALL ID's for a Patient"
2558^MAGD(2006.79,25,1,54,0)=" W ! S DIC=""^DPT("",DIC(0)=""AEMQ"" D ^DIC K DIC G Q6:+Y<1 S DFN=+Y"
2559^MAGD(2006.79,25,1,55,0)="61 W !!,""Are you sure"" S %=2 D YN^DICN"
2560^MAGD(2006.79,25,1,56,0)=" I '% W !?5,""Answer 'YES' if you want to reset all the id's associated"",!?5,""with this patient."",!!?5,""If the id format requires user input, you will be asked to enter the id."" G 61"
2561^MAGD(2006.79,25,1,57,0)=" G 6:%'=1"
2562^MAGD(2006.79,25,1,58,0)="PAT ; -- entry point if DFN is defined"
2563^MAGD(2006.79,25,1,59,0)=" F VAELG=0:0 S VAELG=$O(^DPT(DFN,""E"",VAELG)) Q:'VAELG I $D(^(VAELG,0)),$D(^DIC(8,VAELG,0)) W:'$D(VABATCH) !?5,""..."",$P(^(0),U) D IX I '$D(VABATCH) D ASK^VADPT61 W ?40,$P(^DPT(DFN,""E"",VAELG,0),U,3)_"" / ""_$P(^(0),U,4)"
2564^MAGD(2006.79,25,1,60,0)="Q6 K DFN,VAELG"
2565^MAGD(2006.79,25,1,61,0)=" Q"
2566^MAGD(2006.79,25,1,62,0)=" ;"
2567^MAGD(2006.79,25,1,63,0)="7 ;;Reset ALL ID's for ALL Patients"
2568^MAGD(2006.79,25,1,64,0)=" W !!,""Are you sure"" S %=2 D YN^DICN"
2569^MAGD(2006.79,25,1,65,0)=" I '% W !?5,""Answer 'YES' if you want to reset all the id's associated"",!?5,""with ALL patients."" G 7"
2570^MAGD(2006.79,25,1,66,0)=" G Q7:%'=1"
2571^MAGD(2006.79,25,1,67,0)=" S VAOPT=7 D TASK^VADPT61 G Q7"
2572^MAGD(2006.79,25,1,68,0)="QUE7 S VALL="""" D BEG^VADPT61,ALL,END^VADPT61"
2573^MAGD(2006.79,25,1,69,0)="Q7 K VALL"
2574^MAGD(2006.79,25,1,70,0)=" Q"
2575^MAGD(2006.79,25,1,71,0)=" ;"
2576^MAGD(2006.79,25,1,72,0)="FILE ;"
2577^MAGD(2006.79,25,1,73,0)=" S $P(^DPT(DFN,""E"",0),U,2)=""2.0361P"""
2578^MAGD(2006.79,25,1,74,0)=" I $D(^DPT(DFN,""E"",VAELG,0)) D IX G PATQ"
2579^MAGD(2006.79,25,1,75,0)=" L +^DPT(DFN,""E"",VAELG)"
2580^MAGD(2006.79,25,1,76,0)=" S $P(^(0),""^"",3,4)=VAELG_""^""_($P(^DPT(DFN,""E"",0),""^"",4)+1)"
2581^MAGD(2006.79,25,1,77,0)=" S ^DPT(DFN,""E"",VAELG,0)=VAELG"
2582^MAGD(2006.79,25,1,78,0)=" L -^DPT(DFN,""E"",VAELG)"
2583^MAGD(2006.79,25,1,79,0)=" S DA(1)=DFN,DA=VAELG,DIK=""^DPT(""_DA(1)_"",""""E"""","",DIK(1)="".01"" D EN1^DIK"
2584^MAGD(2006.79,25,1,80,0)=" K DA,DIK Q"
2585^MAGD(2006.79,25,1,81,0)="PATQ Q"
2586^MAGD(2006.79,25,1,82,0)=" ;"
2587^MAGD(2006.79,25,1,83,0)="IX ;"
2588^MAGD(2006.79,25,1,84,0)=" S DA(1)=DFN,DA=VAELG,DIK=""^DPT(""_DA(1)_"",""""E"""","",DIK(1)="".01^3"" D EN^DIK"
2589^MAGD(2006.79,25,1,85,0)=" K DA,DIK Q"
2590^MAGD(2006.79,25,1,86,0)=" ;"
2591^MAGD(2006.79,25,1,87,0)="ALL ; -- resets all id's for all pt's"
2592^MAGD(2006.79,25,1,88,0)=" ; if VALL not defined then only primary reset"
2593^MAGD(2006.79,25,1,89,0)=" F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN D PRI I $D(VALL) F VAELG=0:0 S VAELG=$O(^DPT(DFN,""E"",VAELG)) Q:'VAELG D IX:VAELG'=VAPRI"
2594^MAGD(2006.79,25,1,90,0)=" K VAPRI,DFN,VAELG"
2595^MAGD(2006.79,25,1,91,0)=" Q"
2596^MAGD(2006.79,25,1,92,0)=" ;"
2597^MAGD(2006.79,25,1,93,0)="PRI ; -- set/reset pri elig id"
2598^MAGD(2006.79,25,1,94,0)=" S VAPRI=0"
2599^MAGD(2006.79,25,1,95,0)=" I $D(^DPT(DFN,.36)) S (VAPRI,VAELG)=+^(.36) I $D(^DIC(8,VAELG,0)) D FILE"
2600^MAGD(2006.79,25,1,96,0)=" Q"
2601^MAGD(2006.79,25,1,97,0)=" ;"
2602^MAGD(2006.79,25,1,98,0)="UPDT ; -- called by v5 clean-up"
2603^MAGD(2006.79,25,1,99,0)=" W !,"">>>PRIMARY ELIGIBILITY ID UPDATE..."""
2604^MAGD(2006.79,25,1,100,0)=" D 41 Q"
2605^MAGD(2006.79,26,0)="VADPT61^3050311.125837"
2606^MAGD(2006.79,26,1,0)="^2006.791^60^60"
2607^MAGD(2006.79,26,1,1,0)="VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200"
2608^MAGD(2006.79,26,1,2,0)=" ;;5.3;Registration;;Aug 13, 1993"
2609^MAGD(2006.79,26,1,3,0)=" ;"
2610^MAGD(2006.79,26,1,4,0)="1 ;;ID Format Enter/Edit"
2611^MAGD(2006.79,26,1,5,0)=" W ! S DIC=""^DIC(8.2,"",DIC(0)=""AELMQ"" D ^DIC K DIC G Q1:+Y<1"
2612^MAGD(2006.79,26,1,6,0)=" S DA=+Y,DIE=""^DIC(8.2,"",DR=""[DG ID FORMAT ENTER/EDIT]"" D ^DIE G 1"
2613^MAGD(2006.79,26,1,7,0)="Q1 K DIE,DR,DA,Y Q"
2614^MAGD(2006.79,26,1,8,0)=" ;"
2615^MAGD(2006.79,26,1,9,0)="2 ;;Eligibility Code Enter/Edit"
2616^MAGD(2006.79,26,1,10,0)=" W ! S DIC=""^DIC(8,"",DIC(0)=""AELMQ"",DIC(""DR"")=8 D ^DIC K DIC G Q2:+Y<1"
2617^MAGD(2006.79,26,1,11,0)=" S DA=+Y,DIE=""^DIC(8,"",DR=""[DG ELIG ENTER/EDIT]"" D ^DIE G 2"
2618^MAGD(2006.79,26,1,12,0)="Q2 K DIE,DR,DA,Y"
2619^MAGD(2006.79,26,1,13,0)=" Q"
2620^MAGD(2006.79,26,1,14,0)=" ;"
2621^MAGD(2006.79,26,1,15,0)="ASK ;"
2622^MAGD(2006.79,26,1,16,0)=" Q:$S('$D(^DIC(8.2,+$P(^DIC(8,VAELG,0),U,10),0)):1,1:'$P(^(0),U,2))"
2623^MAGD(2006.79,26,1,17,0)=" W !!,*7,""User Input Needed for '"",$P(^DIC(8,VAELG,0),U),""' id:"""
2624^MAGD(2006.79,26,1,18,0)=" S DIE=""^DPT(""_DFN_"",""""E"""","",DR=.03,DA(1)=DFN,DA=VAELG D ^DIE"
2625^MAGD(2006.79,26,1,19,0)=" W !!?5,""..."",$P(^DIC(8,VAELG,0),U)"
2626^MAGD(2006.79,26,1,20,0)=" K DIE,DR,DA,Y"
2627^MAGD(2006.79,26,1,21,0)=" Q"
2628^MAGD(2006.79,26,1,22,0)=" ;"
2629^MAGD(2006.79,26,1,23,0)="WARN ; -- interaction warning"
2630^MAGD(2006.79,26,1,24,0)=" I $P(X,U,2) W !!?5,*7,""WARNING: User interaction usually is required for this format."""
2631^MAGD(2006.79,26,1,25,0)=" Q"
2632^MAGD(2006.79,26,1,26,0)=" ;"
2633^MAGD(2006.79,26,1,27,0)="BEG ;"
2634^MAGD(2006.79,26,1,28,0)=" D NOW^%DTC S VASTART=%"
2635^MAGD(2006.79,26,1,29,0)=" Q"
2636^MAGD(2006.79,26,1,30,0)=" ;"
2637^MAGD(2006.79,26,1,31,0)="END ;"
2638^MAGD(2006.79,26,1,32,0)=" D NOW^%DTC S VAEND=%,L=0"
2639^MAGD(2006.79,26,1,33,0)=" K XMY"
2640^MAGD(2006.79,26,1,34,0)=" S XMSUB=$P($T(OPTS+VAOPT),"";"",4),XMDUZ=.5,XMTEXT=""VATEXT("",XMY(DUZ)="""""
2641^MAGD(2006.79,26,1,35,0)=" I VAOPT=3 S XMSUB=XMSUB_"" (Format: ""_$S($D(^DIC(8.2,VAFMT,0)):$P(^(0),U),1:""UNKNOWN"")_"")"""
2642^MAGD(2006.79,26,1,36,0)=" I VAOPT=5 S XMSUB=XMSUB_"" (Eligibility: ""_$S($D(^DIC(8,VAELG,0)):$P(^(0),U),1:""UNKNOWN"")_"")"""
2643^MAGD(2006.79,26,1,37,0)=" S L=L+1 S VATEXT(L,0)="" """
2644^MAGD(2006.79,26,1,38,0)=" S Y=VASTART,L=L+1 X ^DD(""DD"") S VATEXT(L,0)="" Job started at ""_Y"
2645^MAGD(2006.79,26,1,39,0)=" S Y=VAEND,L=L+1 X ^DD(""DD"") S VATEXT(L,0)="" Job completed at ""_Y"
2646^MAGD(2006.79,26,1,40,0)=" D ^XMD"
2647^MAGD(2006.79,26,1,41,0)=" K VAOPT,VASTART,VAEND,L,VATEXT,XMY,XMSUB,XMDUZ,XMTEXT,Y,% Q"
2648^MAGD(2006.79,26,1,42,0)=" ;"
2649^MAGD(2006.79,26,1,43,0)="TASK ;"
2650^MAGD(2006.79,26,1,44,0)=" W !!?5,""The resetting of ID formats can take many hours."""
2651^MAGD(2006.79,26,1,45,0)=" W !?5,""It is suggested that it be run at off-peak hours,"""
2652^MAGD(2006.79,26,1,46,0)=" W !?5,""perferably over a weekend."",!"
2653^MAGD(2006.79,26,1,47,0)=" K ZTSK S X=$T(OPTS+VAOPT),VARS=$P(X,"";"",5)"
2654^MAGD(2006.79,26,1,48,0)=" F I=1:1 S Y=$P(VARS,""^"",I) Q:Y="""" S ZTSAVE(Y)="""""
2655^MAGD(2006.79,26,1,49,0)=" S ZTSAVE(""VAOPT"")="""",ZTRTN=""QUE""_VAOPT_""^VADPT60"",ZTDESC=$P(X,"";"",4),ZTIO="""" D ^%ZTLOAD"
2656^MAGD(2006.79,26,1,50,0)=" I $D(ZTSK) W !!,""Job has been queued. (Task #"",ZTSK,"")"",!,""A MailMan message will be sent to you when the job has completed."""
2657^MAGD(2006.79,26,1,51,0)="TASKQ K ZTIO,ZTRTN,ZTDESC,ZTSAVE,VARS,Y,X,ZTSK Q"
2658^MAGD(2006.79,26,1,52,0)=" ;"
2659^MAGD(2006.79,26,1,53,0)="OPTS ; -- queue task list ;;opt#;description;vars to save"
2660^MAGD(2006.79,26,1,54,0)=" ;;1;none"
2661^MAGD(2006.79,26,1,55,0)=" ;;2;none"
2662^MAGD(2006.79,26,1,56,0)=" ;;3;Reset ID Format;VAFMT"
2663^MAGD(2006.79,26,1,57,0)=" ;;4;Reset Primary Eligibilty ID Format"
2664^MAGD(2006.79,26,1,58,0)=" ;;5;Reset Specific Eligibilty ID Format;VAELG"
2665^MAGD(2006.79,26,1,59,0)=" ;;6;none"
2666^MAGD(2006.79,26,1,60,0)=" ;;7;Reset All ID Formats for all Patients"
2667^MAGD(2006.79,27,0)="VADPT62^3050311.125837"
2668^MAGD(2006.79,27,1,0)="^2006.791^50^50"
2669^MAGD(2006.79,27,1,1,0)="VADPT62 ;ALB/MJK - Patient ID Trigger Nodes ; 11 MAR 1991"
2670^MAGD(2006.79,27,1,2,0)=" ;;5.3;Registration;;Aug 13, 1993"
2671^MAGD(2006.79,27,1,3,0)=" ;"
2672^MAGD(2006.79,27,1,4,0)=" ; This routine contains all the the 1 and 2 nodes for triggers"
2673^MAGD(2006.79,27,1,5,0)=" ; on fields in the PATIENT ELIGIBILITIES multiple of the"
2674^MAGD(2006.79,27,1,6,0)=" ; PATIENT file."
2675^MAGD(2006.79,27,1,7,0)=" ;"
2676^MAGD(2006.79,27,1,8,0)=" ; Because of the layered nature of the execution of these"
2677^MAGD(2006.79,27,1,9,0)=" ; triggers, M11+ could not handle their execution reliably."
2678^MAGD(2006.79,27,1,10,0)=" ; Store errors would sometimes occur."
2679^MAGD(2006.79,27,1,11,0)=" ;"
2680^MAGD(2006.79,27,1,12,0)=" ; By placing the code for these nodes in this rouitne, the operating"
2681^MAGD(2006.79,27,1,13,0)=" ; system will not have use up as much symbol space to store the"
2682^MAGD(2006.79,27,1,14,0)=" ; executeable code. The 1 and 2 nodes now only contain calls"
2683^MAGD(2006.79,27,1,15,0)=" ; to the appropriate tag in this routine. [Tag 'P31' is the"
2684^MAGD(2006.79,27,1,16,0)=" ; tag called by the 3rd cross reference of the LONG ID field"
2685^MAGD(2006.79,27,1,17,0)=" ; to execute the 'set' logic of the trigger - ^DD(2.0361,.03,1,3,1).]"
2686^MAGD(2006.79,27,1,18,0)=" ;"
2687^MAGD(2006.79,27,1,19,0)="E31 ; -- first set node of ^DD(2.0361,.01,1,3,1) trigger on ELIGIBILITY field"
2688^MAGD(2006.79,27,1,20,0)=" K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DPT(D0,""E"",D1,0)):^(0),1:"""") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(2.0361,.01,1,3,1.1) X ^DD(2.0361,.01,1,3,1.4)"
2689^MAGD(2006.79,27,1,21,0)=" Q"
2690^MAGD(2006.79,27,1,22,0)=" ;"
2691^MAGD(2006.79,27,1,23,0)="E32 ; -- first kill node of ^DD(2.0361,.01,1,3,2) trigger on ELIGIBILITY field"
2692^MAGD(2006.79,27,1,24,0)=" K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DPT(D0,""E"",D1,0)):^(0),1:"""") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="""" X ^DD(2.0361,.01,1,3,2.4)"
2693^MAGD(2006.79,27,1,25,0)=" Q"
2694^MAGD(2006.79,27,1,26,0)=" ;"
2695^MAGD(2006.79,27,1,27,0)="L11 ; -- first set node of ^DD(2.0361,.03,1,1,1) trigger on LONG ID field"
2696^MAGD(2006.79,27,1,28,0)=" K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DPT(D0,""E"",D1,0)):^(0),1:"""") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(2.0361,.03,1,1,1.1) X ^DD(2.0361,.03,1,1,1.4)"
2697^MAGD(2006.79,27,1,29,0)=" Q"
2698^MAGD(2006.79,27,1,30,0)=" ;"
2699^MAGD(2006.79,27,1,31,0)="L12 ; -- first kill node of ^DD(2.0361,.03,1,1,2) trigger on LONG ID field"
2700^MAGD(2006.79,27,1,32,0)=" K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DPT(D0,""E"",D1,0)):^(0),1:"""") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="""" X ^DD(2.0361,.03,1,1,2.4)"
2701^MAGD(2006.79,27,1,33,0)=" Q"
2702^MAGD(2006.79,27,1,34,0)=" ;"
2703^MAGD(2006.79,27,1,35,0)="L31 ; -- first set node of ^DD(2.0361,.03,1,3,1) trigger on LONG ID field"
2704^MAGD(2006.79,27,1,36,0)=" K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA S Y(0)=X S X=$S('$D(^DPT(DA(1),.36)):0,1:DA=+^(.36)) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.36)):^(.36),1:"""") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(2.0361,.03,1,3,1.4)"
2705^MAGD(2006.79,27,1,37,0)=" Q"
2706^MAGD(2006.79,27,1,38,0)=" ;"
2707^MAGD(2006.79,27,1,39,0)="L32 ; -- first kill node of ^DD(2.0361,.03,1,3,2) trigger on LONG ID"
2708^MAGD(2006.79,27,1,40,0)=" K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA S Y(0)=X S X=$S('$D(^DPT(DA(1),.36)):0,1:DA=+^(.36)) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.36)):^(.36),1:"""") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="""" X ^DD(2.0361,.03,1,3,2.4)"
2709^MAGD(2006.79,27,1,41,0)=" Q"
2710^MAGD(2006.79,27,1,42,0)=" ;"
2711^MAGD(2006.79,27,1,43,0)="S31 ; -- first set node of ^DD(2.0361,.04,1,3,1) trigger on SHORT ID field"
2712^MAGD(2006.79,27,1,44,0)=" K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA S Y(0)=X S X=$S('$D(^DPT(DA(1),.36)):0,1:DA=+^(.36)) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.36)):^(.36),1:"""") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(2.0361,.04,1,3,1.4)"
2713^MAGD(2006.79,27,1,45,0)=" Q"
2714^MAGD(2006.79,27,1,46,0)=" ;"
2715^MAGD(2006.79,27,1,47,0)="S32 ; -- first kill node of ^DD(2.0361,.04,1,3,2) trigger on SHORT ID field"
2716^MAGD(2006.79,27,1,48,0)=" K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA S Y(0)=X S X=$S('$D(^DPT(DA(1),.36)):0,1:DA=+^(.36)) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.36)):^(.36),1:"""") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="""" X ^DD(2.0361,.04,1,3,2.4)"
2717^MAGD(2006.79,27,1,49,0)=" Q"
2718^MAGD(2006.79,27,1,50,0)=" ;"
2719^MAGD(2006.79,28,0)="XLFDT^3050311.125837"
2720^MAGD(2006.79,28,1,0)="^2006.791^178^178"
2721^MAGD(2006.79,28,1,1,0)="XLFDT ;ISC-SF/STAFF - Date/Time Functions ;03/27/2003 14:09"
2722^MAGD(2006.79,28,1,2,0)=" ;;8.0;KERNEL;**71,120,166,168,179,280**;Jul 10, 1995"
2723^MAGD(2006.79,28,1,3,0)=" ;VA FileMan uses 2400 as midnight, many other system use 0000."
2724^MAGD(2006.79,28,1,4,0)=" ;This is true for $H and HL7, so a conversion has to adjust"
2725^MAGD(2006.79,28,1,5,0)=" ;the day when converting Midnight."
2726^MAGD(2006.79,28,1,6,0)=" ;i.e. 3001225.24 is the same as HL7 '200012260000' and $H '58434,0'"
2727^MAGD(2006.79,28,1,7,0)=" ;The range of accepted $H dates: ""2,0"" to ""99999,85399""."
2728^MAGD(2006.79,28,1,8,0)=" ;The range of accepted FM dates: 1410102 to 4141015 (any valid time)."
2729^MAGD(2006.79,28,1,9,0)=" ;The range of accepted HL7 dates: 18410102 to 21141015 (any valid time)."
2730^MAGD(2006.79,28,1,10,0)=" ;It is expected that input values are valid dates."
2731^MAGD(2006.79,28,1,11,0)=" ;"
2732^MAGD(2006.79,28,1,12,0)="HTFM(%H,%F) ;$H to FM, %F=1 for date only"
2733^MAGD(2006.79,28,1,13,0)=" N X,%,%T,%Y,%M,%D S:'$D(%F) %F=0"
2734^MAGD(2006.79,28,1,14,0)=" I $$HR(%H) Q -1 ;Check Range"
2735^MAGD(2006.79,28,1,15,0)=" I '%F,%H["",0"" S %H=(%H-1)_"",86400"""
2736^MAGD(2006.79,28,1,16,0)=" D YMD S:%T&('%F) X=X_%T"
2737^MAGD(2006.79,28,1,17,0)=" Q X"
2738^MAGD(2006.79,28,1,18,0)=" ;"
2739^MAGD(2006.79,28,1,19,0)="H2F(%H) ;Internal to this routine use"
2740^MAGD(2006.79,28,1,20,0)=" N X,%,%T,%Y,%M,%D"
2741^MAGD(2006.79,28,1,21,0)=" D YMD S:%T X=X_%T"
2742^MAGD(2006.79,28,1,22,0)=" Q X"
2743^MAGD(2006.79,28,1,23,0)=" ;"
2744^MAGD(2006.79,28,1,24,0)="YMD ;21608 = 28 feb 1900, 94657 = 28 feb 2100, 141 $H base year"
2745^MAGD(2006.79,28,1,25,0)=" S %=(%H>21608)+(%H>94657)+%H-.1,%Y=%\365.25+141,%=%#365.25\1"
2746^MAGD(2006.79,28,1,26,0)=" S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1"
2747^MAGD(2006.79,28,1,27,0)=" S X=%Y_""00""+%M_""00""+%D,%=$P(%H,"","",2)"
2748^MAGD(2006.79,28,1,28,0)=" S %T=%#60/100+(%#3600\60)/100+(%\3600)/100 S:'%T %T="".0"""
2749^MAGD(2006.79,28,1,29,0)=" Q"
2750^MAGD(2006.79,28,1,30,0)=" ;"
2751^MAGD(2006.79,28,1,31,0)="FMTH(X,%F) ;FM to $H, %F=1 for date only"
2752^MAGD(2006.79,28,1,32,0)=" N %Y,%H,%A S:'$D(%F) %F=0"
2753^MAGD(2006.79,28,1,33,0)=" I $$FR(X) Q -1 ;$H range of 1 - 99999"
2754^MAGD(2006.79,28,1,34,0)=" I '%F,X["".24"" S %A=1"
2755^MAGD(2006.79,28,1,35,0)=" D H S:%F %H=+%H I $D(%A) S %H=(%H+1)_"",0"""
2756^MAGD(2006.79,28,1,36,0)=" Q %H"
2757^MAGD(2006.79,28,1,37,0)=" ;"
2758^MAGD(2006.79,28,1,38,0)="F2H(X) ;Internal to this routine use"
2759^MAGD(2006.79,28,1,39,0)=" N %Y,%H,%A"
2760^MAGD(2006.79,28,1,40,0)=" D H"
2761^MAGD(2006.79,28,1,41,0)=" Q %H"
2762^MAGD(2006.79,28,1,42,0)=" ;"
2763^MAGD(2006.79,28,1,43,0)="H ;Build %H from FM"
2764^MAGD(2006.79,28,1,44,0)=" N %,%L,%M,%D,%T I X<1410101 S %H=0,%Y=-1 Q"
2765^MAGD(2006.79,28,1,45,0)=" S %Y=$E(X,1,3),%M=$E(X,4,5),%D=$E(X,6,7)"
2766^MAGD(2006.79,28,1,46,0)=" S %T=$E(X_0,9,10)*60+$E(X_""000"",11,12)*60+$E(X_""00000"",13,14)"
2767^MAGD(2006.79,28,1,47,0)=" ;%L = (# leap years) - (# leap years before base)"
2768^MAGD(2006.79,28,1,48,0)=" S %L=%Y+1700 S:%M<3 %L=%L-1 S %L=(%L\4)-(%L\100)+(%L\400)-446"
2769^MAGD(2006.79,28,1,49,0)=" S %H=$P(""^31^59^90^120^151^181^212^243^273^304^334"",""^"",%M)+%D"
2770^MAGD(2006.79,28,1,50,0)=" S %=('%M)!('%D),%Y=%Y-141,%H=(%H+(%Y*365)+%L+%)_"",""_%T,%Y=$S(%:-1,1:%H+4#7)"
2771^MAGD(2006.79,28,1,51,0)=" Q"
2772^MAGD(2006.79,28,1,52,0)=" ;"
2773^MAGD(2006.79,28,1,53,0)="HTE(%H,%F) ;$H to external"
2774^MAGD(2006.79,28,1,54,0)=" Q:$$HR(%H) %H ;Range Check"
2775^MAGD(2006.79,28,1,55,0)=" N Y,%T,%R"
2776^MAGD(2006.79,28,1,56,0)=" S %F=$G(%F,1) S Y=$$HTFM(%H,0) G T2"
2777^MAGD(2006.79,28,1,57,0)=" ;"
2778^MAGD(2006.79,28,1,58,0)="FMTE(Y,%F) ;FM to external"
2779^MAGD(2006.79,28,1,59,0)=" Q:(Y<1000000)!(Y>9991231) Y ;Range Check"
2780^MAGD(2006.79,28,1,60,0)=" N %T,%R S %F=$G(%F,1)"
2781^MAGD(2006.79,28,1,61,0)=" ;Both HTE and FMTE come here."
2782^MAGD(2006.79,28,1,62,0)="T2 S %T="".""_$E($P(Y,""."",2)_""000000"",1,7)"
2783^MAGD(2006.79,28,1,63,0)=" D FMT^XLFDT1 Q %R"
2784^MAGD(2006.79,28,1,64,0)=" ;"
2785^MAGD(2006.79,28,1,65,0)="FR(%V) ;Check FM in valid range"
2786^MAGD(2006.79,28,1,66,0)=" Q (%V<1410102)!(%V>4141015.235959)"
2787^MAGD(2006.79,28,1,67,0)="HR(%V) ;Check $H in valid range"
2788^MAGD(2006.79,28,1,68,0)=" Q (%V<2)!(%V>99999)"
2789^MAGD(2006.79,28,1,69,0)=" ;"
2790^MAGD(2006.79,28,1,70,0)="FMTHL7(%P1) ;Convert FM date/time to HL7 format"
2791^MAGD(2006.79,28,1,71,0)=" N %T Q:'$L(%P1) """" S %P1=+%P1 ;Make sure a cononic number"
2792^MAGD(2006.79,28,1,72,0)=" I $$FR(%P1) Q -1 ;Check range"
2793^MAGD(2006.79,28,1,73,0)=" S %T=$P(%P1,""."",2),%P1=$P(%P1,""."")"
2794^MAGD(2006.79,28,1,74,0)=" I %T=24 S %P1=$$FMADD($P(%P1,"".""),1),%T=""0000"""
2795^MAGD(2006.79,28,1,75,0)=" S:%P1>1 %P1=%P1+17000000"
2796^MAGD(2006.79,28,1,76,0)=" I $L(%T) S %T=$S($L(%T)>4:$E(%T_""00"",1,6),1:$E(%T_""0000"",1,4))"
2797^MAGD(2006.79,28,1,77,0)=" I $L(%T) S %P1=%P1_%T_$$TZ()"
2798^MAGD(2006.79,28,1,78,0)=" Q %P1"
2799^MAGD(2006.79,28,1,79,0)=" ;"
2800^MAGD(2006.79,28,1,80,0)="HL7TFM(%P1,%P2,%P3) ;Convert HL7 D/T to FM."
2801^MAGD(2006.79,28,1,81,0)=" ;%P1 is the value to convert"
2802^MAGD(2006.79,28,1,82,0)=" ;%P2 is if output should be local or UCT time (L,U)"
2803^MAGD(2006.79,28,1,83,0)=" ;%P3 is 1 if the input just a time value?"
2804^MAGD(2006.79,28,1,84,0)=" N %TZ,%LTZ,%SN,%U,%H,%M,%T Q:'$L(%P1) """""
2805^MAGD(2006.79,28,1,85,0)=" S %T=$E(%P1_""0000"",1,8)"
2806^MAGD(2006.79,28,1,86,0)=" S %P2=$G(%P2),%P3=+$G(%P3),%TZ="""",%LTZ=$$TZ()"
2807^MAGD(2006.79,28,1,87,0)=" I '%P3 Q:(%T<18410102)!(%T>21141015) -1 ;Date Range Check"
2808^MAGD(2006.79,28,1,88,0)=" F %SN=""+"",""-"" I %P1[%SN D Q ;Find the timezone"
2809^MAGD(2006.79,28,1,89,0)=" . S %TZ=$P(%P1,%SN,2),%P1=$P(%P1,%SN) I %TZ'?4N S %TZ="""" Q"
2810^MAGD(2006.79,28,1,90,0)=" . S %TZ=%SN_%TZ"
2811^MAGD(2006.79,28,1,91,0)=" . Q"
2812^MAGD(2006.79,28,1,92,0)=" ;FM only supports time to seconds"
2813^MAGD(2006.79,28,1,93,0)=" S %P1=$P(%P1,""."")"
2814^MAGD(2006.79,28,1,94,0)=" ;See it just a Time value"
2815^MAGD(2006.79,28,1,95,0)=" I %P3 S %P1=""20000104""_%P1 ;Add a date"
2816^MAGD(2006.79,28,1,96,0)=" Q:($L(%P1)#2)!(%P1'?4.14N) -1 ;Length check"
2817^MAGD(2006.79,28,1,97,0)=" I $L(%P1)<8 S %P1=$E(%P1_""00000000"",1,8) ;Fill out to 8 digits"
2818^MAGD(2006.79,28,1,98,0)=" I %TZ="""" D"
2819^MAGD(2006.79,28,1,99,0)=" . S:%P2[""L"" %P2="""" ;If no TZ, assume local, don't need L."
2820^MAGD(2006.79,28,1,100,0)=" . S:%P2[""U"" %TZ=%LTZ ;give the local tz"
2821^MAGD(2006.79,28,1,101,0)=" ;"
2822^MAGD(2006.79,28,1,102,0)=" S %P1=$S($L(%P1)>8:$E(%P1,1,8)-17000000_"".""_$E(%P1,9,14),1:%P1-17000000)"
2823^MAGD(2006.79,28,1,103,0)=" ;%P1 is now in FM format"
2824^MAGD(2006.79,28,1,104,0)=" I %P1[""."",+$P(%P1,""."",2)=0 S %P1=$$FMADD(+%P1,-1)_"".24"""
2825^MAGD(2006.79,28,1,105,0)=" ;If HL7 tz and local tz are the same"
2826^MAGD(2006.79,28,1,106,0)=" I %P2[""L"",%TZ=%LTZ S %P2="""""
2827^MAGD(2006.79,28,1,107,0)=" I (%P2[""U"")!(%P2[""L""),%P1[""."" D ;Build UCT from data"
2828^MAGD(2006.79,28,1,108,0)=" . S %=$TR(%TZ,""+-"",""-+"") ;Reverse the sign"
2829^MAGD(2006.79,28,1,109,0)=" . S %H=$E(%,1,3),%M=$E(%,1)_$E(%,4,5)"
2830^MAGD(2006.79,28,1,110,0)=" . S %P1=$$FMADD(%P1,,%H,%M) Q"
2831^MAGD(2006.79,28,1,111,0)=" ;"
2832^MAGD(2006.79,28,1,112,0)=" I %P2[""L"",%P1[""."" D ;Build local from UCT"
2833^MAGD(2006.79,28,1,113,0)=" . S %=$$TZ(),%H=$E(%,1,3),%M=$E(%,1)_$E(%,4,5)"
2834^MAGD(2006.79,28,1,114,0)=" . S %P1=$$FMADD(%P1,,%H,%M) Q"
2835^MAGD(2006.79,28,1,115,0)=" Q +$S(%P3:"".""_$P(%P1,""."",2),1:%P1)"
2836^MAGD(2006.79,28,1,116,0)=" ;"
2837^MAGD(2006.79,28,1,117,0)="DOW(X,Y) ;Day of Week"
2838^MAGD(2006.79,28,1,118,0)=" N %Y,%M,%D,%H,%T D H I $G(Y) Q %Y"
2839^MAGD(2006.79,28,1,119,0)=" Q $P(""Sun^Mon^Tues^Wednes^Thurs^Fri^Satur"",""^"",%Y+1)_""day"""
2840^MAGD(2006.79,28,1,120,0)=" ;"
2841^MAGD(2006.79,28,1,121,0)="FMDIFF(X1,X2,X3) ;FM diff in two dates. if X3=1 in days, if X3=2 in seconds."
2842^MAGD(2006.79,28,1,122,0)=" N %H,%Y,X"
2843^MAGD(2006.79,28,1,123,0)=" S X1=$G(X1),X2=$G(X2),X3=$G(X3,1)"
2844^MAGD(2006.79,28,1,124,0)=" S:$$FR(X1) X1=0 S:$$FR(X2) X2=0 ;Check range, Use 0 for bad values"
2845^MAGD(2006.79,28,1,125,0)=" S X=X1 D H S X1=+%H,X1(1)=$P(%H,"","",2),X=X2 D H"
2846^MAGD(2006.79,28,1,126,0)=" ;Both FMDIFF and HDIFF come here."
2847^MAGD(2006.79,28,1,127,0)="D2 S X=(X1-%H) S:X3>1 X=X*86400+(X1(1)-$P(%H,"","",2))"
2848^MAGD(2006.79,28,1,128,0)=" I X3=3 S %=X,X="""" S:%'<86400 X=(%\86400) S:%#86400 X=X_"" ""_(%#86400\3600)_"":""_$E(%#3600\60+100,2,3)_"":""_$E(%#60+100,2,3)"
2849^MAGD(2006.79,28,1,129,0)=" Q X"
2850^MAGD(2006.79,28,1,130,0)=" ;"
2851^MAGD(2006.79,28,1,131,0)="HDIFF(X1,X2,X3) ;$H diff in two dates, X3 same as FMDIFF."
2852^MAGD(2006.79,28,1,132,0)=" N X,%H,%T"
2853^MAGD(2006.79,28,1,133,0)=" S:$$HR(X1) X1=""1,1"" S:$$HR(X2) X2=""1,1"" ;Check range, use ""1,1"" for bad values"
2854^MAGD(2006.79,28,1,134,0)=" S X3=$G(X3,1)"
2855^MAGD(2006.79,28,1,135,0)=" S X1(1)=$P(X1,"","",2),X1=+X1,%H=X2"
2856^MAGD(2006.79,28,1,136,0)=" G D2"
2857^MAGD(2006.79,28,1,137,0)=" ;"
2858^MAGD(2006.79,28,1,138,0)="HADD(X,D,H,M,S) ;Add to $H date"
2859^MAGD(2006.79,28,1,139,0)=" N %H,%T"
2860^MAGD(2006.79,28,1,140,0)=" Q:$$HR(X) -1 ;Check Range"
2861^MAGD(2006.79,28,1,141,0)=" S %H=+X,%T=$P(X,"","",2) D A2 Q %H_"",""_%T"
2862^MAGD(2006.79,28,1,142,0)=" ;"
2863^MAGD(2006.79,28,1,143,0)="A2 S %H=%H+$G(D),%T=%T+($G(H)*3600)+($G(M)*60)+$G(S) ;add days and seconds"
2864^MAGD(2006.79,28,1,144,0)=" ;S:%T'<86400 %H=%H+(%T\86400),%T=%T#86400 S:%T<0 %H=%H+(%T\86400)-1,%T=%T#86400"
2865^MAGD(2006.79,28,1,145,0)=" S %H=%H+(%T\86400) I %T<0,(%T#86400'=0) S %H=%H-1 ;Adj for sec>day"
2866^MAGD(2006.79,28,1,146,0)=" S %T=%T#86400"
2867^MAGD(2006.79,28,1,147,0)=" Q"
2868^MAGD(2006.79,28,1,148,0)=" ;"
2869^MAGD(2006.79,28,1,149,0)="FMADD(X,D,H,M,S) ;Add to FM date"
2870^MAGD(2006.79,28,1,150,0)=" N %H,%T,%P"
2871^MAGD(2006.79,28,1,151,0)=" Q:$$FR(X) -1 ;Check Range"
2872^MAGD(2006.79,28,1,152,0)=" S %P=X[""."",%H=$$F2H(X),%T=$P(%H,"","",2) D A2"
2873^MAGD(2006.79,28,1,153,0)=" I %P,%T=0 S %H=%H-1,%T=86400"
2874^MAGD(2006.79,28,1,154,0)=" Q $$H2F(%H_"",""_%T)"
2875^MAGD(2006.79,28,1,155,0)=" ;"
2876^MAGD(2006.79,28,1,156,0)="NOW() ;Current Date/time in FM."
2877^MAGD(2006.79,28,1,157,0)=" Q $$HTFM($H)"
2878^MAGD(2006.79,28,1,158,0)=" ;"
2879^MAGD(2006.79,28,1,159,0)="DT() ;Current Date in FM."
2880^MAGD(2006.79,28,1,160,0)=" Q $$HTFM($H,1)\1"
2881^MAGD(2006.79,28,1,161,0)=" ;"
2882^MAGD(2006.79,28,1,162,0)="SCH(SCH,LTM,FF) ;Find the next D/T given a schedule, start time."
2883^MAGD(2006.79,28,1,163,0)=" Q $$DECODE^XLFDT2"
2884^MAGD(2006.79,28,1,164,0)=" ;"
2885^MAGD(2006.79,28,1,165,0)="WITHIN(XLSCH,XLD) ;See if D/T is within schedule"
2886^MAGD(2006.79,28,1,166,0)=" G WITHIN^XLFDT4"
2887^MAGD(2006.79,28,1,167,0)=" ;"
2888^MAGD(2006.79,28,1,168,0)="SEC(%) ;Convert $H to seconds."
2889^MAGD(2006.79,28,1,169,0)=" I %?7.N.""."".N S %=$$FMTH(%) ;Check for FM date"
2890^MAGD(2006.79,28,1,170,0)=" Q 86400*%+$P(%,"","",2)"
2891^MAGD(2006.79,28,1,171,0)=" ;"
2892^MAGD(2006.79,28,1,172,0)="%H(%) ;Covert from seconds to $H"
2893^MAGD(2006.79,28,1,173,0)=" Q (%\86400)_"",""_(%#86400)"
2894^MAGD(2006.79,28,1,174,0)=" ;"
2895^MAGD(2006.79,28,1,175,0)="TZ() ;Return current Time Zone from Mailman parameter file"
2896^MAGD(2006.79,28,1,176,0)=" N %T,%S"
2897^MAGD(2006.79,28,1,177,0)=" S %T=$P($G(^XMB(4.4,+$P($G(^XMB(1,1,0)),""^"",2),0)),""^"",3),%S=$S(%T[""-"":""-"",1:""+""),%T=$TR(%T,""-+"")"
2898^MAGD(2006.79,28,1,178,0)=" Q %S_$E(100+%T,2,3)_$S(%T["".5"":""30"",1:""00"")"
2899^MAGD(2006.79,29,0)="XUMF333^3050311.125837"
2900^MAGD(2006.79,29,1,0)="^2006.791^356^356"
2901^MAGD(2006.79,29,1,1,0)="XUMF333 ;OIFO-OAK/RAM - Add HCS data types ;02/21/02"
2902^MAGD(2006.79,29,1,2,0)=" ;;8.0;KERNEL;**335**;Jul 10, 1995"
2903^MAGD(2006.79,29,1,3,0)=" ;"
2904^MAGD(2006.79,29,1,4,0)=" Q"
2905^MAGD(2006.79,29,1,5,0)=" ;"
2906^MAGD(2006.79,29,1,6,0)=" ;"
2907^MAGD(2006.79,29,1,7,0)="POST ; -- post installation XU*8*333"
2908^MAGD(2006.79,29,1,8,0)=" ;"
2909^MAGD(2006.79,29,1,9,0)=" N XUMF,IENS,IEN,FDA,I,HCS,XXX"
2910^MAGD(2006.79,29,1,10,0)=" ;"
2911^MAGD(2006.79,29,1,11,0)=" S XUMF=1"
2912^MAGD(2006.79,29,1,12,0)=" ;"
2913^MAGD(2006.79,29,1,13,0)=" D KM,KM1,KM2,KM3,STUFF"
2914^MAGD(2006.79,29,1,14,0)=" ;"
2915^MAGD(2006.79,29,1,15,0)=" Q"
2916^MAGD(2006.79,29,1,16,0)=" ;"
2917^MAGD(2006.79,29,1,17,0)="KM ; -- add XUMF IMF EDIT STATUS to XUKERNEL"
2918^MAGD(2006.79,29,1,18,0)=" ;"
2919^MAGD(2006.79,29,1,19,0)=" N X,Y"
2920^MAGD(2006.79,29,1,20,0)=" ;"
2921^MAGD(2006.79,29,1,21,0)=" S X=$$FIND1^DIC(19,,""B"",""XUKERNEL"")"
2922^MAGD(2006.79,29,1,22,0)=" S Y=""?+1,"""
2923^MAGD(2006.79,29,1,23,0)=" ;"
2924^MAGD(2006.79,29,1,24,0)=" S IENS=Y_X_"","""
2925^MAGD(2006.79,29,1,25,0)=" S FDA(19,""?1,"",.01)=""XUKERNEL"""
2926^MAGD(2006.79,29,1,26,0)=" S FDA(19.01,""?+2,?1,"",.01)=""XUMF IMF EDIT STATUS"""
2927^MAGD(2006.79,29,1,27,0)=" D UPDATE^DIE("""",""FDA"")"
2928^MAGD(2006.79,29,1,28,0)=" ;"
2929^MAGD(2006.79,29,1,29,0)=" Q"
2930^MAGD(2006.79,29,1,30,0)=" ;"
2931^MAGD(2006.79,29,1,31,0)="KM1 ; -- add XUMF IMF EDIT STATUS to XUKERNEL"
2932^MAGD(2006.79,29,1,32,0)=" ;"
2933^MAGD(2006.79,29,1,33,0)=" N X,Y"
2934^MAGD(2006.79,29,1,34,0)=" ;"
2935^MAGD(2006.79,29,1,35,0)=" S X=$$FIND1^DIC(19,,""B"",""XUKERNEL"")"
2936^MAGD(2006.79,29,1,36,0)=" S Y=""?+1,"""
2937^MAGD(2006.79,29,1,37,0)=" ;"
2938^MAGD(2006.79,29,1,38,0)=" S IENS=Y_X_"","""
2939^MAGD(2006.79,29,1,39,0)=" S FDA(19,""?1,"",.01)=""XUKERNEL"""
2940^MAGD(2006.79,29,1,40,0)=" S FDA(19.01,""?+3,?1,"",.01)=""XUMF LOAD INSTITUTION"""
2941^MAGD(2006.79,29,1,41,0)=" D UPDATE^DIE("""",""FDA"")"
2942^MAGD(2006.79,29,1,42,0)=" ;"
2943^MAGD(2006.79,29,1,43,0)=" Q"
2944^MAGD(2006.79,29,1,44,0)=" ;"
2945^MAGD(2006.79,29,1,45,0)="KM2 ; -- add XUMF IMF EDIT STATUS to XUKERNEL"
2946^MAGD(2006.79,29,1,46,0)=" ;"
2947^MAGD(2006.79,29,1,47,0)=" N X,Y"
2948^MAGD(2006.79,29,1,48,0)=" ;"
2949^MAGD(2006.79,29,1,49,0)=" S X=$$FIND1^DIC(19,,""B"",""XUKERNEL"")"
2950^MAGD(2006.79,29,1,50,0)=" S Y=""?+1,"""
2951^MAGD(2006.79,29,1,51,0)=" ;"
2952^MAGD(2006.79,29,1,52,0)=" S IENS=Y_X_"","""
2953^MAGD(2006.79,29,1,53,0)=" S FDA(19,""?1,"",.01)=""XUKERNEL"""
2954^MAGD(2006.79,29,1,54,0)=" S FDA(19.01,""?+3,?1,"",.01)=""Patch XU*8*335 clean 4.1 and 4"""
2955^MAGD(2006.79,29,1,55,0)=" D UPDATE^DIE("""",""FDA"")"
2956^MAGD(2006.79,29,1,56,0)=" ;"
2957^MAGD(2006.79,29,1,57,0)=" Q"
2958^MAGD(2006.79,29,1,58,0)=" ;"
2959^MAGD(2006.79,29,1,59,0)="KM3 ; -- remove XUMF333 clean 4.1 and 4 if present"
2960^MAGD(2006.79,29,1,60,0)=" ;"
2961^MAGD(2006.79,29,1,61,0)=" N X,IENS,FDA"
2962^MAGD(2006.79,29,1,62,0)=" ;"
2963^MAGD(2006.79,29,1,63,0)=" S X=$$FIND1^DIC(19,,""B"",""XUMF333 clean 4.1 and 4"")"
2964^MAGD(2006.79,29,1,64,0)=" ;"
2965^MAGD(2006.79,29,1,65,0)=" Q:'X"
2966^MAGD(2006.79,29,1,66,0)=" ;"
2967^MAGD(2006.79,29,1,67,0)=" S IENS=X_"","""
2968^MAGD(2006.79,29,1,68,0)=" S FDA(19,IENS,.01)=""@"""
2969^MAGD(2006.79,29,1,69,0)=" D UPDATE^DIE("""",""FDA"")"
2970^MAGD(2006.79,29,1,70,0)=" ;"
2971^MAGD(2006.79,29,1,71,0)=" Q"
2972^MAGD(2006.79,29,1,72,0)=" ;"
2973^MAGD(2006.79,29,1,73,0)="STUFF ;"
2974^MAGD(2006.79,29,1,74,0)=" ;"
2975^MAGD(2006.79,29,1,75,0)=" S IEN=$O(^DIC(4.1,""B"",""HCS"",0))"
2976^MAGD(2006.79,29,1,76,0)=" S IENS=$S(IEN:IEN_"","",1:""+1,"")"
2977^MAGD(2006.79,29,1,77,0)=" K FDA"
2978^MAGD(2006.79,29,1,78,0)=" S FDA(4.1,IENS,.01)=""HCS"""
2979^MAGD(2006.79,29,1,79,0)=" S FDA(4.1,IENS,1)=""HEALTH CARE SYSTEM"""
2980^MAGD(2006.79,29,1,80,0)=" S FDA(4.1,IENS,3)=""LOCAL"""
2981^MAGD(2006.79,29,1,81,0)=" D UPDATE^DIE(""E"",""FDA"")"
2982^MAGD(2006.79,29,1,82,0)=" ;"
2983^MAGD(2006.79,29,1,83,0)=" S HCS="""""
2984^MAGD(2006.79,29,1,84,0)=" F XXX=1:1 D Q:HCS="""""
2985^MAGD(2006.79,29,1,85,0)=" .S HCS=$P($T(HCS+XXX),"";;"",2)"
2986^MAGD(2006.79,29,1,86,0)=" .S IEN=$S(HCS="""":0,1:$O(^DIC(4,""B"",HCS,0)))"
2987^MAGD(2006.79,29,1,87,0)=" .S IENS=$S(IEN:IEN_"","",1:""+1,"")"
2988^MAGD(2006.79,29,1,88,0)=" .;"
2989^MAGD(2006.79,29,1,89,0)=" .K FDA"
2990^MAGD(2006.79,29,1,90,0)=" .S FDA(4,IENS,.01)=HCS"
2991^MAGD(2006.79,29,1,91,0)=" .S FDA(4,IENS,11)=""LOCAL"""
2992^MAGD(2006.79,29,1,92,0)=" .S FDA(4,IENS,13)=""HCS"""
2993^MAGD(2006.79,29,1,93,0)=" .D UPDATE^DIE(""E"",""FDA"")"
2994^MAGD(2006.79,29,1,94,0)=" ;"
2995^MAGD(2006.79,29,1,95,0)=" Q"
2996^MAGD(2006.79,29,1,96,0)=" ;"
2997^MAGD(2006.79,29,1,97,0)="HCS ;"
2998^MAGD(2006.79,29,1,98,0)=" ;;VA GREATER LOS ANGELES (691)"
2999^MAGD(2006.79,29,1,99,0)=" ;;VA HEARTLAND-EAST VISN15 (657)"
3000^MAGD(2006.79,29,1,100,0)=" ;;VA HEARTLAND-WEST VISN15 (589)"
3001^MAGD(2006.79,29,1,101,0)=" ;;VA CHICAGO HSC (537)"
3002^MAGD(2006.79,29,1,102,0)=" ;;CENTRAL PLAINS NETWORK (636)"
3003^MAGD(2006.79,29,1,103,0)=" ;;MONTANA HCS (436)"
3004^MAGD(2006.79,29,1,104,0)=" ;;VA PACIFIC ISLANDS HCS (459)"
3005^MAGD(2006.79,29,1,105,0)=" ;;NEW MEXICO HCS (501)"
3006^MAGD(2006.79,29,1,106,0)=" ;;AMARILLO HCS (504)"
3007^MAGD(2006.79,29,1,107,0)=" ;;MARYLAND HCS (512)"
3008^MAGD(2006.79,29,1,108,0)=" ;;WEST TEXAS HCS (519)"
3009^MAGD(2006.79,29,1,109,0)=" ;;BOSTON HCS (523)"
3010^MAGD(2006.79,29,1,110,0)=" ;;UPSTATE NEW YORK HCS (528)"
3011^MAGD(2006.79,29,1,111,0)=" ;;NORTH TEXAS HCS (549)"
3012^MAGD(2006.79,29,1,112,0)=" ;;EASTERN COLORADO HCS (554)"
3013^MAGD(2006.79,29,1,113,0)=" ;;NEW JERSEY HCS (561)"
3014^MAGD(2006.79,29,1,114,0)=" ;;BLACK HILLS HCS (568)"
3015^MAGD(2006.79,29,1,115,0)=" ;;CENTRAL CALIFORNIA HCS (570)"
3016^MAGD(2006.79,29,1,116,0)=" ;;N FLORIDA/S GEORGIA HCS (573)"
3017^MAGD(2006.79,29,1,117,0)=" ;;GREATER NEBRASKA HCS (597)"
3018^MAGD(2006.79,29,1,118,0)=" ;;CENTRAL ARKANSAS HCS (598)"
3019^MAGD(2006.79,29,1,119,0)=" ;;LONG BEACH HCS (600)"
3020^MAGD(2006.79,29,1,120,0)=" ;;CENTRAL ALABAMA HCS (619)"
3021^MAGD(2006.79,29,1,121,0)=" ;;HUDSON VALLEY HCS VAMC (620)"
3022^MAGD(2006.79,29,1,122,0)=" ;;TENNESSEE VALLEY HCS (626)"
3023^MAGD(2006.79,29,1,123,0)=" ;;PALO ALTO HCS (640)"
3024^MAGD(2006.79,29,1,124,0)=" ;;PITTSBURGH HCS (646)"
3025^MAGD(2006.79,29,1,125,0)=" ;;ROSEBURG HCS (653)"
3026^MAGD(2006.79,29,1,126,0)=" ;;SIERRA NEVADA HCS (654)"
3027^MAGD(2006.79,29,1,127,0)=" ;;SALT LAKE CITY HCS (660)"
3028^MAGD(2006.79,29,1,128,0)=" ;;PUGET SOUND HCS (663)"
3029^MAGD(2006.79,29,1,129,0)=" ;;SAN DIEGO HCS (664)"
3030^MAGD(2006.79,29,1,130,0)=" ;;SOUTH TEXAS HCS (671)"
3031^MAGD(2006.79,29,1,131,0)=" ;;CENTRAL TEXAS HCS (674)"
3032^MAGD(2006.79,29,1,132,0)=" ;;EASTERN KANSAS HCS (677)"
3033^MAGD(2006.79,29,1,133,0)=" ;;SOUTHERN ARIZONA VA HCS (678)"
3034^MAGD(2006.79,29,1,134,0)=" ;;CONNECTICUT HCS (689)"
3035^MAGD(2006.79,29,1,135,0)=" ;;EL PASO VA HCS (756)"
3036^MAGD(2006.79,29,1,136,0)=" ;;NEW YORK HHS (630)"
3037^MAGD(2006.79,29,1,137,0)=" ;"
3038^MAGD(2006.79,29,1,138,0)=" ; do not include"
3039^MAGD(2006.79,29,1,139,0)=" ;;EASTERN COLORADO HCS (554A4)"
3040^MAGD(2006.79,29,1,140,0)=" ;;SOUTHERN COLORADO HCS"
3041^MAGD(2006.79,29,1,141,0)=" ;;CENTRAL IOWA HCS (555)"
3042^MAGD(2006.79,29,1,142,0)=" ;;ILLIANA HCS (550)"
3043^MAGD(2006.79,29,1,143,0)=" ;;NORTHERN CALIFORNIA HCS (612)"
3044^MAGD(2006.79,29,1,144,0)=" ;;SOUTHERN NEVADA HCS (593)"
3045^MAGD(2006.79,29,1,145,0)=" ;;NORTHERN ARIZONA HCS (649)"
3046^MAGD(2006.79,29,1,146,0)=" ;"
3047^MAGD(2006.79,29,1,147,0)=" Q"
3048^MAGD(2006.79,29,1,148,0)=" ;"
3049^MAGD(2006.79,29,1,149,0)="CHK ; -- check site updating required"
3050^MAGD(2006.79,29,1,150,0)=" ;"
3051^MAGD(2006.79,29,1,151,0)=" N STA,IEN,FLAG,CHK"
3052^MAGD(2006.79,29,1,152,0)=" ;"
3053^MAGD(2006.79,29,1,153,0)=" S STA=$$STA^XUAF4(+$G(DUZ(2)))"
3054^MAGD(2006.79,29,1,154,0)=" ;"
3055^MAGD(2006.79,29,1,155,0)=" I STA="""" W !!,""DUZ not defined. Please log on."" Q"
3056^MAGD(2006.79,29,1,156,0)=" ;"
3057^MAGD(2006.79,29,1,157,0)=" W @IOF,!,STA,"" "",$P($$NS^XUAF4(+DUZ(2)),U)"
3058^MAGD(2006.79,29,1,158,0)=" ;"
3059^MAGD(2006.79,29,1,159,0)=" S CHK=$$INST^XUMF333(+DUZ(2),.ERR)"
3060^MAGD(2006.79,29,1,160,0)=" I CHK=1 D"
3061^MAGD(2006.79,29,1,161,0)=" .W !!?5,""MISSING DATA - please fix"",!"
3062^MAGD(2006.79,29,1,162,0)=" .S I=0 F S I=$O(ERR(""FATAL"",I)) Q:'I D"
3063^MAGD(2006.79,29,1,163,0)=" ..W !?5,ERR(""FATAL"",I)"
3064^MAGD(2006.79,29,1,164,0)=" I CHK'=1 W "" is okay"""
3065^MAGD(2006.79,29,1,165,0)=" ;"
3066^MAGD(2006.79,29,1,166,0)=" S STA=STA_""A"""
3067^MAGD(2006.79,29,1,167,0)=" F S STA=$O(^DIC(4,""D"",STA)) Q:STA="""" D Q:$G(FLAG)"
3068^MAGD(2006.79,29,1,168,0)=" .I $E($$STA^XUAF4(DUZ(2)),1,3)'=$E(STA,1,3) S FLAG=1 Q"
3069^MAGD(2006.79,29,1,169,0)=" .S IEN=$$IEN^XUAF4(STA)"
3070^MAGD(2006.79,29,1,170,0)=" .S CHK=$$INST^XUMF333(+IEN,.ERR)"
3071^MAGD(2006.79,29,1,171,0)=" .W !!,STA,"" "",$P($$NS^XUAF4(+IEN),U)"
3072^MAGD(2006.79,29,1,172,0)=" .I CHK'=1 W "" is okay"" Q"
3073^MAGD(2006.79,29,1,173,0)=" .I CHK=1 D"
3074^MAGD(2006.79,29,1,174,0)=" ..W "" is MISSING DATA - please fix"",!"
3075^MAGD(2006.79,29,1,175,0)=" ..S I=0 F S I=$O(ERR(""FATAL"",I)) Q:'I D"
3076^MAGD(2006.79,29,1,176,0)=" ...W !?5,ERR(""FATAL"",I)"
3077^MAGD(2006.79,29,1,177,0)=" .K ERR"
3078^MAGD(2006.79,29,1,178,0)=" ;"
3079^MAGD(2006.79,29,1,179,0)=" ;"
3080^MAGD(2006.79,29,1,180,0)=" Q"
3081^MAGD(2006.79,29,1,181,0)=" ;"
3082^MAGD(2006.79,29,1,182,0)="INST(IEN,ERR) ; -- validate Institution entry FALSE=valid"
3083^MAGD(2006.79,29,1,183,0)=" ;"
3084^MAGD(2006.79,29,1,184,0)=" Q:'$G(IEN) ""IEN null"""
3085^MAGD(2006.79,29,1,185,0)=" ;"
3086^MAGD(2006.79,29,1,186,0)=" S CNT=1"
3087^MAGD(2006.79,29,1,187,0)=" ;"
3088^MAGD(2006.79,29,1,188,0)=" D ZERO(IEN,.ERR,.CNT)"
3089^MAGD(2006.79,29,1,189,0)=" D ADD1(IEN,.ERR,.CNT)"
3090^MAGD(2006.79,29,1,190,0)=" D ADD2(IEN,.ERR,.CNT)"
3091^MAGD(2006.79,29,1,191,0)=" D FTYP(IEN,.ERR,.CNT)"
3092^MAGD(2006.79,29,1,192,0)=" D ND99(IEN,.ERR,.CNT)"
3093^MAGD(2006.79,29,1,193,0)=" ;"
3094^MAGD(2006.79,29,1,194,0)=" Q $S($D(ERR(""FATAL"")):1,$D(ERR(""WARNING"")):2,1:0)"
3095^MAGD(2006.79,29,1,195,0)=" ;"
3096^MAGD(2006.79,29,1,196,0)="ZERO(IEN,ERR,CNT) ; -- zero node"
3097^MAGD(2006.79,29,1,197,0)=" ;"
3098^MAGD(2006.79,29,1,198,0)=" N X"
3099^MAGD(2006.79,29,1,199,0)=" ;"
3100^MAGD(2006.79,29,1,200,0)=" S CNT=$G(CNT) S:'CNT CNT=1"
3101^MAGD(2006.79,29,1,201,0)=" ;"
3102^MAGD(2006.79,29,1,202,0)=" S X=$G(^DIC(4,+IEN,0))"
3103^MAGD(2006.79,29,1,203,0)=" I $P(X,U,2)="""" D"
3104^MAGD(2006.79,29,1,204,0)=" .S ERR(""FATAL"",CNT)=""STATE is missing"",CNT=CNT+1"
3105^MAGD(2006.79,29,1,205,0)=" ;"
3106^MAGD(2006.79,29,1,206,0)=" Q"
3107^MAGD(2006.79,29,1,207,0)=" ;"
3108^MAGD(2006.79,29,1,208,0)="ADD1(IEN,ERR,CNT) ; -- address node"
3109^MAGD(2006.79,29,1,209,0)=" ;"
3110^MAGD(2006.79,29,1,210,0)=" N X,I"
3111^MAGD(2006.79,29,1,211,0)=" ;"
3112^MAGD(2006.79,29,1,212,0)=" S CNT=$G(CNT) S:'CNT CNT=1"
3113^MAGD(2006.79,29,1,213,0)=" ;"
3114^MAGD(2006.79,29,1,214,0)=" S X=$G(^DIC(4,+IEN,1))"
3115^MAGD(2006.79,29,1,215,0)=" I $P(X,U,1)="""" D"
3116^MAGD(2006.79,29,1,216,0)=" .S ERR(""FATAL"",CNT)=""Physical address St. line 1 missing"""
3117^MAGD(2006.79,29,1,217,0)=" .S CNT=CNT+1"
3118^MAGD(2006.79,29,1,218,0)=" I $P(X,U,3)="""" D"
3119^MAGD(2006.79,29,1,219,0)=" .S ERR(""FATAL"",CNT)=""Physical address City missing"""
3120^MAGD(2006.79,29,1,220,0)=" .S CNT=CNT+1"
3121^MAGD(2006.79,29,1,221,0)=" I $P(X,U,4)="""" D"
3122^MAGD(2006.79,29,1,222,0)=" .S ERR(""FATAL"",CNT)=""Physical address ZIP missing"""
3123^MAGD(2006.79,29,1,223,0)=" .S CNT=CNT+1"
3124^MAGD(2006.79,29,1,224,0)=" I $P(X,U,2)="""" D"
3125^MAGD(2006.79,29,1,225,0)=" .S ERR(""WARNING"",CNT)=""Physical address St. line 2 missing"""
3126^MAGD(2006.79,29,1,226,0)=" .S CNT=CNT+1"
3127^MAGD(2006.79,29,1,227,0)=" ;"
3128^MAGD(2006.79,29,1,228,0)=" Q"
3129^MAGD(2006.79,29,1,229,0)=" ;"
3130^MAGD(2006.79,29,1,230,0)="ADD2(IEN,ERR,CNT) ; -- mailing address node"
3131^MAGD(2006.79,29,1,231,0)=" ;"
3132^MAGD(2006.79,29,1,232,0)=" N X,I"
3133^MAGD(2006.79,29,1,233,0)=" ;"
3134^MAGD(2006.79,29,1,234,0)=" S CNT=$G(CNT) S:'CNT CNT=1"
3135^MAGD(2006.79,29,1,235,0)=" ;"
3136^MAGD(2006.79,29,1,236,0)=" S X=$G(^DIC(4,+IEN,4))"
3137^MAGD(2006.79,29,1,237,0)=" I $P(X,U,1)="""" D"
3138^MAGD(2006.79,29,1,238,0)=" .S ERR(""FATAL"",CNT)=""Mailing address St. line 1 missing"""
3139^MAGD(2006.79,29,1,239,0)=" .S CNT=CNT+1"
3140^MAGD(2006.79,29,1,240,0)=" I $P(X,U,3)="""" D"
3141^MAGD(2006.79,29,1,241,0)=" .S ERR(""FATAL"",CNT)=""Mailing address City missing"""
3142^MAGD(2006.79,29,1,242,0)=" .S CNT=CNT+1"
3143^MAGD(2006.79,29,1,243,0)=" I $P(X,U,4)="""" D"
3144^MAGD(2006.79,29,1,244,0)=" .S ERR(""FATAL"",CNT)=""Mailing address State missing"""
3145^MAGD(2006.79,29,1,245,0)=" .S CNT=CNT+1"
3146^MAGD(2006.79,29,1,246,0)=" I $P(X,U,5)="""" D"
3147^MAGD(2006.79,29,1,247,0)=" .S ERR(""FATAL"",CNT)=""Mailing address ZIP missing"""
3148^MAGD(2006.79,29,1,248,0)=" .S CNT=CNT+1"
3149^MAGD(2006.79,29,1,249,0)=" I $P(X,U,2)="""" D"
3150^MAGD(2006.79,29,1,250,0)=" .S ERR(""WARNING"",CNT)=""Mailing address St. line 2 missing"""
3151^MAGD(2006.79,29,1,251,0)=" .S CNT=CNT+1"
3152^MAGD(2006.79,29,1,252,0)=" ;"
3153^MAGD(2006.79,29,1,253,0)=" Q"
3154^MAGD(2006.79,29,1,254,0)=" ;"
3155^MAGD(2006.79,29,1,255,0)="FTYP(IEN,ERR,CNT) ; -- facility type node"
3156^MAGD(2006.79,29,1,256,0)=" ;"
3157^MAGD(2006.79,29,1,257,0)=" N X"
3158^MAGD(2006.79,29,1,258,0)=" ;"
3159^MAGD(2006.79,29,1,259,0)=" S CNT=$G(CNT) S:'CNT CNT=1"
3160^MAGD(2006.79,29,1,260,0)=" ;"
3161^MAGD(2006.79,29,1,261,0)=" S X=$G(^DIC(4,+IEN,3))"
3162^MAGD(2006.79,29,1,262,0)=" I 'X D"
3163^MAGD(2006.79,29,1,263,0)=" .S ERR(""FATAL"",CNT)=""FACILITY TYPE is missing"",CNT=CNT+1"
3164^MAGD(2006.79,29,1,264,0)=" I $P($G(^DIC(4.1,+X,0)),U,4)'=""N"" D"
3165^MAGD(2006.79,29,1,265,0)=" .S ERR(""FATAL"",CNT)=""FACILITY TYPE is not NATIONAL"",CNT=CNT+1"
3166^MAGD(2006.79,29,1,266,0)=" ;"
3167^MAGD(2006.79,29,1,267,0)=" Q"
3168^MAGD(2006.79,29,1,268,0)=" ;"
3169^MAGD(2006.79,29,1,269,0)="ND99(IEN,ERR,CNT) ; -- 99 node"
3170^MAGD(2006.79,29,1,270,0)=" ;"
3171^MAGD(2006.79,29,1,271,0)=" N X"
3172^MAGD(2006.79,29,1,272,0)=" ;"
3173^MAGD(2006.79,29,1,273,0)=" S CNT=$G(CNT) S:'CNT CNT=1"
3174^MAGD(2006.79,29,1,274,0)=" ;"
3175^MAGD(2006.79,29,1,275,0)=" S X=$G(^DIC(4,+IEN,99))"
3176^MAGD(2006.79,29,1,276,0)=" I $P(X,U,3)="""" D"
3177^MAGD(2006.79,29,1,277,0)=" .S ERR(""FATAL"",CNT)=""OFFICIAL VA NAME is missing"",CNT=CNT+1"
3178^MAGD(2006.79,29,1,278,0)=" I ($P(X,U,4))&($E($$NS^XUAF4(+IEN),1,2)'=""ZZ"") D"
3179^MAGD(2006.79,29,1,279,0)=" .S ERR(""FATAL"",CNT)=""Inactive facility NAME not ZZ'd"",CNT=CNT+1"
3180^MAGD(2006.79,29,1,280,0)=" ;"
3181^MAGD(2006.79,29,1,281,0)=" Q"
3182^MAGD(2006.79,29,1,282,0)=" ;"
3183^MAGD(2006.79,29,1,283,0)="C4 ; -- clean up Institution file"
3184^MAGD(2006.79,29,1,284,0)=" ;"
3185^MAGD(2006.79,29,1,285,0)=" D RIP,CFTYP,GET"
3186^MAGD(2006.79,29,1,286,0)=" ;"
3187^MAGD(2006.79,29,1,287,0)=" Q"
3188^MAGD(2006.79,29,1,288,0)=" ;"
3189^MAGD(2006.79,29,1,289,0)="RIP ; -- remove from all inactive and local the associations visn & parent"
3190^MAGD(2006.79,29,1,290,0)=" ;"
3191^MAGD(2006.79,29,1,291,0)=" N IEN"
3192^MAGD(2006.79,29,1,292,0)=" ;"
3193^MAGD(2006.79,29,1,293,0)=" S IEN=0"
3194^MAGD(2006.79,29,1,294,0)=" F S IEN=$O(^DIC(4,IEN)) Q:'IEN D"
3195^MAGD(2006.79,29,1,295,0)=" .I $P($G(^DIC(4,+IEN,0)),U,11)=""N"",'$P($G(^DIC(4,+IEN,99)),U,4) Q"
3196^MAGD(2006.79,29,1,296,0)=" .D IFF^XUMF333(IEN)"
3197^MAGD(2006.79,29,1,297,0)=" ;"
3198^MAGD(2006.79,29,1,298,0)=" Q"
3199^MAGD(2006.79,29,1,299,0)=" ;"
3200^MAGD(2006.79,29,1,300,0)="IFF(IEN) ; -- inactive facility remove VISN and parent association"
3201^MAGD(2006.79,29,1,301,0)=" ;"
3202^MAGD(2006.79,29,1,302,0)=" N FDA,IENS,XUMF"
3203^MAGD(2006.79,29,1,303,0)=" ;"
3204^MAGD(2006.79,29,1,304,0)=" S XUMF=1"
3205^MAGD(2006.79,29,1,305,0)=" ;"
3206^MAGD(2006.79,29,1,306,0)=" S IENS=""1,""_IEN_"","""
3207^MAGD(2006.79,29,1,307,0)=" S FDA(4.014,IENS,.01)=""@"""
3208^MAGD(2006.79,29,1,308,0)=" S IENS=""2,""_IEN_"","""
3209^MAGD(2006.79,29,1,309,0)=" S FDA(4.014,IENS,.01)=""@"""
3210^MAGD(2006.79,29,1,310,0)=" D FILE^DIE(""E"",""FDA"")"
3211^MAGD(2006.79,29,1,311,0)=" ;"
3212^MAGD(2006.79,29,1,312,0)=" Q"
3213^MAGD(2006.79,29,1,313,0)=" ;"
3214^MAGD(2006.79,29,1,314,0)="CFTYP ; - clean 4.1"
3215^MAGD(2006.79,29,1,315,0)=" ;"
3216^MAGD(2006.79,29,1,316,0)=" N FDA,IENS,XUMF,IEN"
3217^MAGD(2006.79,29,1,317,0)=" ;"
3218^MAGD(2006.79,29,1,318,0)=" M ^TMP(""XUMF 4.1"",$J)=^DIC(4.1)"
3219^MAGD(2006.79,29,1,319,0)=" ;"
3220^MAGD(2006.79,29,1,320,0)=" S XUMF=1"
3221^MAGD(2006.79,29,1,321,0)=" ;"
3222^MAGD(2006.79,29,1,322,0)=" S IEN=0"
3223^MAGD(2006.79,29,1,323,0)=" F S IEN=$O(^DIC(4.1,IEN)) Q:'IEN D"
3224^MAGD(2006.79,29,1,324,0)=" .S IENS=IEN_"","""
3225^MAGD(2006.79,29,1,325,0)=" .K FDA"
3226^MAGD(2006.79,29,1,326,0)=" .S FDA(4.1,IENS,.01)=""@"""
3227^MAGD(2006.79,29,1,327,0)=" .D FILE^DIE(""E"",""FDA"")"
3228^MAGD(2006.79,29,1,328,0)=" ;"
3229^MAGD(2006.79,29,1,329,0)=" S IEN=0"
3230^MAGD(2006.79,29,1,330,0)=" F S IEN=$O(^DIC(4,IEN)) Q:'IEN D"
3231^MAGD(2006.79,29,1,331,0)=" .S IENS=IEN_"","""
3232^MAGD(2006.79,29,1,332,0)=" .K FDA"
3233^MAGD(2006.79,29,1,333,0)=" .S FDA(4,IENS,13)=""@"""
3234^MAGD(2006.79,29,1,334,0)=" .D FILE^DIE(""E"",""FDA"")"
3235^MAGD(2006.79,29,1,335,0)=" ;"
3236^MAGD(2006.79,29,1,336,0)=" Q"
3237^MAGD(2006.79,29,1,337,0)=" ;"
3238^MAGD(2006.79,29,1,338,0)="GET ; -- get Institution Master File (IMF) and Facility Types"
3239^MAGD(2006.79,29,1,339,0)=" ;"
3240^MAGD(2006.79,29,1,340,0)=" W !!,""...getting Facility Types - wait please 5 min..."""
3241^MAGD(2006.79,29,1,341,0)=" D LOAD^XUMF(4.1)"
3242^MAGD(2006.79,29,1,342,0)=" W !!,""...getting Institutions - wait please 10 min..."""
3243^MAGD(2006.79,29,1,343,0)=" D LOAD^XUMF(4)"
3244^MAGD(2006.79,29,1,344,0)=" ;"
3245^MAGD(2006.79,29,1,345,0)=" Q"
3246^MAGD(2006.79,29,1,346,0)=" ;"
3247^MAGD(2006.79,29,1,347,0)="SCN(IEN,XUMF) ; screen out HCS entries"
3248^MAGD(2006.79,29,1,348,0)=" ;"
3249^MAGD(2006.79,29,1,349,0)=" ; IEN = Institution Internal Entry Number to check"
3250^MAGD(2006.79,29,1,350,0)=" ;"
3251^MAGD(2006.79,29,1,351,0)=" S XUMF=$G(XUMF) Q:XUMF 1"
3252^MAGD(2006.79,29,1,352,0)=" ;"
3253^MAGD(2006.79,29,1,353,0)=" I $O(^DIC(4.1,""B"",""HCS"",0))=+$G(^DIC(4,+IEN,3)) Q 0"
3254^MAGD(2006.79,29,1,354,0)=" ;"
3255^MAGD(2006.79,29,1,355,0)=" Q 1"
3256^MAGD(2006.79,29,1,356,0)=" ;"
3257^MAGD(2006.79,30,0)="XUSRB1^3050311.125837"
3258^MAGD(2006.79,30,1,0)="^2006.791^66^66"
3259^MAGD(2006.79,30,1,1,0)="XUSRB1 ;iscSF/RWF - More Request Broker ;6/8/04 16:41"
3260^MAGD(2006.79,30,1,2,0)=" ;;8.0;KERNEL;**28,82,135,275**;Jul 10, 1995"
3261^MAGD(2006.79,30,1,3,0)=" Q ;No entry from top"
3262^MAGD(2006.79,30,1,4,0)=" ;"
3263^MAGD(2006.79,30,1,5,0)="DECRYP(S) ;decrypt passed string"
3264^MAGD(2006.79,30,1,6,0)=" ;VYD 5/19/95"
3265^MAGD(2006.79,30,1,7,0)=" N ASSOCIX,IDIX,ASSOCSTR,IDSTR"
3266^MAGD(2006.79,30,1,8,0)=" Q:$L(S)'>2 """" ;Bad call"
3267^MAGD(2006.79,30,1,9,0)=" S ASSOCIX=$A($E(S,$L(S)))-31 ;get associator string index"
3268^MAGD(2006.79,30,1,10,0)=" S IDIX=$A($E(S))-31 ;get identifier string index"
3269^MAGD(2006.79,30,1,11,0)=" S ASSOCSTR=$P($T(Z+ASSOCIX),"";"",3,9) ;get associator string"
3270^MAGD(2006.79,30,1,12,0)=" S IDSTR=$P($T(Z+IDIX),"";"",3,9) ;get identifier string"
3271^MAGD(2006.79,30,1,13,0)=" Q $TR($E(S,2,$L(S)-1),ASSOCSTR,IDSTR) ;translated result"
3272^MAGD(2006.79,30,1,14,0)=" ;"
3273^MAGD(2006.79,30,1,15,0)="ENCRYP(S) ;RWF 2/5/96"
3274^MAGD(2006.79,30,1,16,0)=" N %,ASSOCIX,IDIX,ASSOCSTR,IDSTR"
3275^MAGD(2006.79,30,1,17,0)=" S ASSOCIX=$R(20)+1 ;get associator index"
3276^MAGD(2006.79,30,1,18,0)=" F S IDIX=$R(20)+1 Q:ASSOCIX'=IDIX ;get different identifier index"
3277^MAGD(2006.79,30,1,19,0)=" S ASSOCSTR=$P($T(Z+ASSOCIX),"";"",3,9) ;get associator string"
3278^MAGD(2006.79,30,1,20,0)=" S IDSTR=$P($T(Z+IDIX),"";"",3,9) ;get identifier string"
3279^MAGD(2006.79,30,1,21,0)=" ;translated result"
3280^MAGD(2006.79,30,1,22,0)=" Q $C(IDIX+31)_$TR(S,IDSTR,ASSOCSTR)_$C(ASSOCIX+31)"
3281^MAGD(2006.79,30,1,23,0)=" ;"
3282^MAGD(2006.79,30,1,24,0)="SENDKEYS(RESULT) ;send encryption keys to the client"
3283^MAGD(2006.79,30,1,25,0)=" ;VYD 5/19/95"
3284^MAGD(2006.79,30,1,26,0)=" N %,X"
3285^MAGD(2006.79,30,1,27,0)=" S %=1"
3286^MAGD(2006.79,30,1,28,0)=" F S X=$P($T(Z+%),"";"",3,9) Q:X="""" S RESULT(%)=X,%=%+1"
3287^MAGD(2006.79,30,1,29,0)=" Q"
3288^MAGD(2006.79,30,1,30,0)=" ;"
3289^MAGD(2006.79,30,1,31,0)="BLDDRUM Q ;don't run this tag"
3290^MAGD(2006.79,30,1,32,0)=" N I,%,ALLCHARS,RNDMSTR,CHAR"
3291^MAGD(2006.79,30,1,33,0)=" X ""ZP Z"" ;position insertion point"
3292^MAGD(2006.79,30,1,34,0)=" F I=1:1:20 D"
3293^MAGD(2006.79,30,1,35,0)=" . S ALLCHARS="""" F %=32:1:126 S:$C(%)'=""^"" ALLCHARS=ALLCHARS_$C(%)"
3294^MAGD(2006.79,30,1,36,0)=" . S RNDMSTR="""""
3295^MAGD(2006.79,30,1,37,0)=" . F %=1:1:94 D"
3296^MAGD(2006.79,30,1,38,0)=" . . S POS=$R($L(ALLCHARS))+1,CHAR=$E(ALLCHARS,POS)"
3297^MAGD(2006.79,30,1,39,0)=" . . S RNDMSTR=RNDMSTR_CHAR"
3298^MAGD(2006.79,30,1,40,0)=" . . S ALLCHARS=$P(ALLCHARS,CHAR,1)_$P(ALLCHARS,CHAR,2) ;compress by 1"
3299^MAGD(2006.79,30,1,41,0)=" . X ""ZI """" ;;""""_RNDMSTR"" ;save random string in routine"
3300^MAGD(2006.79,30,1,42,0)=" X ""ZS"" ;save routine"
3301^MAGD(2006.79,30,1,43,0)=" Q"
3302^MAGD(2006.79,30,1,44,0)=" ;"
3303^MAGD(2006.79,30,1,45,0)=" ;"
3304^MAGD(2006.79,30,1,46,0)="Z ;;"
3305^MAGD(2006.79,30,1,47,0)=" ;;wkEo-ZJt!dG)49K{nX1BS$vH<&:Myf*>Ae0jQW=;|#PsO`'%+rmb[gpqN,l6/hFC@DcUa ]z~R}""V\iIxu?872.(TYL5_3"
3306^MAGD(2006.79,30,1,48,0)=" ;;rKv`R;M/9BqAF%&tSs#Vh)dO1DZP> *fX'u[.4lY=-mg_ci802N7LTG<]!CWo:3?{+,5Q}(@jaExn$~p\IyHwzU""|k6Jeb"
3307^MAGD(2006.79,30,1,49,0)=" ;;\pV(ZJk""WQmCn!Y,y@1d+~8s?[lNMxgHEt=uw|X:qSLjAI*}6zoF{T3#;ca)/h5%`P4$r]G'9e2if_>UDKb7<v0&- RBO."
3308^MAGD(2006.79,30,1,50,0)=" ;;depjt3g4W)qD0V~NJar\B ""?OYhcu[<Ms%Z`RIL_6:]AX-zG.#}$@vk7/5x&*m;(yb2Fn+l'PwUof1K{9,|EQi>H=CT8S!"
3309^MAGD(2006.79,30,1,51,0)=" ;;NZW:1}K$byP;jk)7'`x90B|cq@iSsEnu,(l-hf.&Y_?J#R]+voQXU8mrV[!p4tg~OMez CAaGFD6H53%L/dT2<*>""{\wI="
3310^MAGD(2006.79,30,1,52,0)=" ;;vCiJ<oZ9|phXVNn)m K`t/SI%]A5qOWe\&?;jT~M!fz1l>[D_0xR32c*4.P""G{r7}E8wUgyudF+6-:B=$(sY,LkbHa#'@Q"
3311^MAGD(2006.79,30,1,53,0)=" ;;hvMX,'4Ty;[a8/{6l~F_V""}qLI\!@x(D7bRmUH]W15J%N0BYPkrs&9:$)Zj>u|zwQ=ieC-oGA.#?tfdcO3gp`S+En K2*<"
3312^MAGD(2006.79,30,1,54,0)=" ;;jd!W5[];4'<C$/&x|rZ(k{>?ghBzIFN}fAK""#`p_TqtD*1E37XGVs@0nmSe+Y6Qyo-aUu%i8c=H2vJ\) R:MLb.9,wlO~P"
3313^MAGD(2006.79,30,1,55,0)=" ;;2ThtjEM+!=xXb)7,ZV{*ci3""8@_l-HS69L>]\AUF/Q%:qD?1~m(yvO0e'<#o$p4dnIzKP|`NrkaGg.ufCRB[; sJYwW}5&"
3314^MAGD(2006.79,30,1,56,0)=" ;;vB\5/zl-9y:Pj|=(R'7QJI *&CTX""p0]_3.idcuOefVU#omwNZ`$Fs?L+1Sk<,b)hM4A6[Y%aDrg@~KqEW8t>H};n!2xG{"
3315^MAGD(2006.79,30,1,57,0)=" ;;sFz0Bo@_HfnK>LR}qWXV+D6`Y28=4Cm~G/7-5A\b9!a#rP.l&M$hc3ijQk;),TvUd<[:I""u1'NZSOw]*gxtE{eJp|y (?%"
3316^MAGD(2006.79,30,1,58,0)=" ;;M@,D}|LJyGO8`$*ZqH .j>c~h<d=fimszv[#-53F!+a;NC'6T91IV?(0x&/{B)w""]Q\YUWprk4:ol%g2nE7teRKbAPuS_X"
3317^MAGD(2006.79,30,1,59,0)=" ;;.mjY#_0*H<B=Q+FML6]s;r2:e8R}[ic&KA 1w{)vV5d,$u""~xD/Pg?IyfthO@CzWp%!`N4Z'3-(o|J9XUE7k\TlqSb>anG"
3318^MAGD(2006.79,30,1,60,0)=" ;;xVa1']_GU<X`|\NgM?LS9{""jT%s$}y[nvtlefB2RKJW~(/cIDCPow4,>#zm+:5b@06O3Ap8=*7ZFY!H-uEQk; .q)i&rhd"
3319^MAGD(2006.79,30,1,61,0)=" ;;I]Jz7AG@QX.""%3Lq>METUo{Pp_ |a6<0dYVSv8:b)~W9NK`(r'4fs&wim\kReC2hg=HOj$1B*/nxt,;c#y+![?lFuZ-5D}"
3320^MAGD(2006.79,30,1,62,0)=" ;;Rr(Ge6F Hx>q$m&C%M~Tn,:""o'tX/*yP.{lZ!YkiVhuw_<KE5a[;}W0gjsz3]@7cI2\QN?f#4p|vb1OUBD9)=-LJA+d`S8"
3321^MAGD(2006.79,30,1,63,0)=" ;;I~k>y|m};d)-7DZ""Fe/Y<B:xwojR,Vh]O0Sc[`$sg8GXE!1&Qrzp._W%TNK(=J 3i*2abuHA4C'?Mv\Pq{n#56LftUl@9+"
3322^MAGD(2006.79,30,1,64,0)=" ;;~A*>9 WidFN,1KsmwQ)GJM{I4:C%}#Ep(?HB/r;t.&U8o|l['Lg""2hRDyZ5`nbf]qjc0!zS-TkYO<_=76a\X@$Pe3+xVvu"
3323^MAGD(2006.79,30,1,65,0)=" ;;yYgjf""5VdHc#uA,W1i+v'6|@pr{n;DJ!8(btPGaQM.LT3oe?NB/&9>Z`-}02*%x<7lsqz4OS ~E$\R]KI[:UwC_=h)kXmF"
3324^MAGD(2006.79,30,1,66,0)=" ;;5:iar.{YU7mBZR@-K|2 ""+~`M%8sq4JhPo<_X\Sg3WC;Tuxz,fvEQ1p9=w}FAI&j/keD0c?)LN6OHV]lGy'$*>nd[(tb!#"
3325^MAGD(2006.79,"B","MCUIMAG0",1)=""
3326^MAGD(2006.79,"B","RARIC",2)=""
3327^MAGD(2006.79,"B","RARTE2",3)=""
3328^MAGD(2006.79,"B","RAUTL",4)=""
3329^MAGD(2006.79,"B","RAUTL1",5)=""
3330^MAGD(2006.79,"B","RAUTL2",6)=""
3331^MAGD(2006.79,"B","RAUTL20",7)=""
3332^MAGD(2006.79,"B","RAUTL3",8)=""
3333^MAGD(2006.79,"B","RAUTL5",9)=""
3334^MAGD(2006.79,"B","RAXREF",10)=""
3335^MAGD(2006.79,"B","TIULC1",11)=""
3336^MAGD(2006.79,"B","TIULS",12)=""
3337^MAGD(2006.79,"B","TIUSRVPL",13)=""
3338^MAGD(2006.79,"B","VADPT",14)=""
3339^MAGD(2006.79,"B","VADPT0",15)=""
3340^MAGD(2006.79,"B","VADPT1",16)=""
3341^MAGD(2006.79,"B","VADPT2",17)=""
3342^MAGD(2006.79,"B","VADPT3",18)=""
3343^MAGD(2006.79,"B","VADPT30",19)=""
3344^MAGD(2006.79,"B","VADPT31",20)=""
3345^MAGD(2006.79,"B","VADPT32",21)=""
3346^MAGD(2006.79,"B","VADPT4",22)=""
3347^MAGD(2006.79,"B","VADPT5",23)=""
3348^MAGD(2006.79,"B","VADPT6",24)=""
3349^MAGD(2006.79,"B","VADPT60",25)=""
3350^MAGD(2006.79,"B","VADPT61",26)=""
3351^MAGD(2006.79,"B","VADPT62",27)=""
3352^MAGD(2006.79,"B","XLFDT",28)=""
3353^MAGD(2006.79,"B","XUMF333",29)=""
3354^MAGD(2006.79,"B","XUSRB1",30)=""
Note: See TracBrowser for help on using the repository browser.