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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1DG53729P ;ALB/JRC - Add NURSING HOME TREATING SPECIALTIES ; 3/12/07 7:21am
2 ;;5.3;Registration;**729**;Aug 13, 1993;Build 59
3 ;base program: DG53683P
4EN ;Add Treating Specialties to the SPECIALITY file (#42.4)
5 N DGI,DGERR,DGSPEC,DGIFN,DGQUES
6 S DGIFN=0
7 ;add new treating specialties
8 F DGI=1:1 S DGSPEC=$P($T(TRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
9 .D TSPEC
10 .S DGQUES=$P(DGSPEC,U,9)
11 .D FAC
12 .Q
13 ;edit existing treating specialties
14 D EDIT
15 ;inactivate existing treating specialties
16 D INACT
17 ;edit existing surgical specialties
18 D EDIT^DG53729R
19 ;move ptf code (those < 100) into new austin ptf code field
20 D APTFC
21 ;place option out of order and remove from menu
22 D MENU
23 ;inactivate existing ptf expanded code categories
24 D PTFCAT^DG53729R
25 ;Update 9/30/2007 Census close out date, if exists
26 D EN^DG53729C
27 Q
28TSPEC ;Add treating specialty to SPECIALTY File (#42.4)
29 D BMES^XPDUTL(">>>"_$P(DGSPEC,U,2)_">>>")
30 N DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y
31 S DGERR=0
32 S DIC="^DIC(42.4,"
33 S DIC(0)="LX"
34 S DINUM=$P(DGSPEC,U)
35 S X=$P(DGSPEC,U,2)
36 S DLAYGO=42.4
37 D ^DIC
38 S (DGIFN,DGDA1)=Y
39 I +DGIFN=-1 D Q
40 .D MES^XPDUTL(" Entry not added to SPECIALTY File (#42.4). No further updating will occur.")
41 .D MES^XPDUTL(" Please contact Customer Service for assistance.")
42 .Q
43 I $P(DGIFN,U,3)'=1&(+DGIFN'=$P(DGSPEC,U)) D Q
44 .D MES^XPDUTL(" Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")
45 .D MES^XPDUTL(" No further updating will occur. Please review entry.")
46 .S DGERR=1
47 .Q
48 D MES^XPDUTL(" Entry "_$S($P(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")
49 D MES^XPDUTL(" Updating SPECIALTY File fields.")
50 S DIE=DIC
51 S DR="1///"_$P(DGSPEC,U,3)_";3///"_$P(DGSPEC,U,4)_";4///"_$P(DGSPEC,U,5)_";5///"_$P(DGSPEC,U,6)_";6///"_$P(DGSPEC,U,7)_";7///"_$P(DGSPEC,U,10)
52 S DA=+DGIFN
53 D ^DIE
54 S DGFILE=42.4
55 S DGMULT=10
56 S DIC="^DIC(42.4,"_+DGIFN_",""E"","
57 D MULT
58 Q
59FAC ;Add treating specialty to Facility Treating Specialty file (#45.7)
60 N DA,DGFILE,DGMULT,DIC,DIE,DLAYGO,DR,X,Y
61 S DIC="^DIC(45.7,"
62 S DIC(0)="LXZ"
63 S DLAYGO=45.7
64 S X=$P(DGSPEC,U,2)
65 D ^DIC
66 S DGDA1=Y
67 I +DGDA1=-1 D BMES^XPDUTL(" Entry not added to FACILITY TREATING SPECIALTY File(#45.7).") Q
68 I $P(DGDA1,U,3)'=1&($P(Y(0),U,2)'=$P(DGSPEC,U)) D Q
69 .D BMES^XPDUTL(" Entry exists in FACILITY TREATING SPECIALTY File (#45.7), but with")
70 .D MES^XPDUTL(" a different PTF Code #. No further updating will occur.")
71 .D MES^XPDUTL(" Please review entry.")
72 .Q
73 D BMES^XPDUTL(" Entry "_$S($P(DGDA1,U,3)=1:"added to",1:"exists in")_" FACILITY TREATING SPECIALTY File (#45.7).")
74 D MES^XPDUTL(" Updating SPECIALTY field...")
75 S DIE=DIC
76 S DA=+DGDA1
77 S DR="1////"_$P(DGSPEC,U)
78 D ^DIE
79 S DGFILE=45.7
80 S DGMULT=100
81 S DIC="^DIC(45.7,"_+DGDA1_",""E"","
82 D MULT
83 Q
84MULT ;Add Effective Date
85 N DA,DIE,DR
86 S DA(1)=+DGDA1
87 S DIC(0)="LX"
88 S DIC("P")=$P(^DD(DGFILE,DGMULT,0),"^",2)
89 S X=3071001
90 D ^DIC
91 S DA=+Y
92 I +Y=-1 D MES^XPDUTL(" Effective date not added.") Q
93 D MES^XPDUTL(" Effective date added.")
94 S DIE=DIC
95 S DR=".02///Y"
96 D ^DIE
97 Q
98INACT ;inactivate treating specialties
99 N DA,DIE,DR,X,DGTSP
100 F DGTSP=1,7,34 D
101 . S DIC="^DIC(42.4,"_DGTSP_",""E"","
102 . S DA(1)=DGTSP
103 . S DIC(0)="LX"
104 . S DIC("P")=$P(^DD(42.4,10,0),"^",2)
105 . S X=3071001
106 . D ^DIC
107 . S DA=+Y
108 . I +Y=-1 D BMES^XPDUTL(">>>Inactive date not added to TS code "_DGTSP_" in the Specialty file.<<<") Q
109 . D BMES^XPDUTL(">>>Inactive date added to TS code "_DGTSP_" in the Specialty file.<<<")
110 . S DIE=DIC
111 . S DR=".02///N"
112 . D ^DIE
113 . ;check for CODES in the Facility Treating Specialty File (45.7
114 . ;add inactivation date of 7/1/2006
115 . D BMES^XPDUTL(" ")
116 . D MES^XPDUTL(" FACILITY TREATING SPECIALTY FILE being checked to see if any entries are")
117 . D MES^XPDUTL(" pointing to "_DGTSP_". If so, they will be inactivated.>>>")
118 .N DAA F DAA=0:0 S DAA=$O(^DIC(45.7,"ASPEC",DGTSP,DAA)) Q:'DAA D
119 .. N DIE,DR,TS,X S TS=""
120 ..S TS=$P($G(^DIC(45.7,DAA,0)),"^")
121 ..S DIC="^DIC(45.7,"_DAA_",""E"","
122 ..S DA(1)=DAA
123 ..S DIC(0)="LX"
124 ..S X=3060701
125 ..D ^DIC
126 ..S DA=+Y
127 ..I +Y=-1 D BMES^XPDUTL(" Inactive date not added to "_TS_"in the Facility Treating Specialty file.") Q
128 ..D BMES^XPDUTL(" Inactive date added to "_TS_" in the Facility Treating Specialty file.<<<")
129 ..S DIE=DIC
130 ..S DR=".02///N"
131 ..D ^DIE
132 Q
133EDIT ;Edit treating specialties
134 ;
135 N DS,DIE,DR,DGI
136 S DIE="^DIC(42.4,"
137 S DIC(0)="LX"
138 F DGI=1:1 S DGSPEC=$P($T(ETRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
139 . S DGERR=0
140 . S DA=$P(DGSPEC,U)
141 . S DR=".01///"_$P(DGSPEC,U,2)_";1///"_$P(DGSPEC,U,3)_";3///"_$P(DGSPEC,U,4)_";4///"_$P(DGSPEC,U,5)_";5///"_$P(DGSPEC,U,6)_";6///"_$P(DGSPEC,U,7)
142 . D ^DIE
143 . D BMES^XPDUTL(" ")
144 . D BMES^XPDUTL(" ")
145 . D BMES^XPDUTL(">>>"_$P(DGSPEC,U)_" code updated to "_$P(DGSPEC,U,2)_" in the Specialty file.>>>")
146 N DS,DIE,DR,DGI,DGII,DGSP,CNT,DGSPEC,DGSPEC1
147 S DIE="^DIC(45.7,"
148 S DIC(0)="LX"
149 F DGI=1:1 S DGSPEC=$P($T(ETRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
150 . S DGERR=0
151 . S DGSP=$P(DGSPEC,U)
152 . S CNT=0,DGSPEC1=0 F DGII=0:0 S DGSPEC1=$O(^DIC(45.7,"ASPEC",DGSP,DGSPEC1)) Q:'DGSPEC1 S CNT=CNT+1 D
153 .. I CNT=1 D
154 ... I $$ACTIVE^DGACT(45.7,DGSPEC1)'=1 S CNT=0 Q
155 ... S DA=DGSPEC1,DR=".01///"_$P(DGSPEC,U,2)_";99///@"
156 ... D BMES^XPDUTL(" "_$P(^DIC(45.7,DGSPEC1,0),U)_" name has been changed to "_$P(DGSPEC,U,2)_" in the Facility Treating Specialty file.")
157 ... D ^DIE
158 .. E D
159 ... S TS=""
160 ... S TS=$P($G(^DIC(45.7,DGSPEC1,0)),"^")
161 ... D BMES^XPDUTL(" Please review Facility Treating Specialty "_TS_". The entry name may need changing or entry may need inactivating since more than one entry points to "_$P(DGSPEC,U,2)_" in the Specialty file.<<<")
162 Q
163TRSP ;PTF code^Specialty^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#^Austin PTF Code
164 ;;13^CARDIAC INTENSIVE CARE UNIT^^MEDICINE^N^GENERAL MEDICAL CARE^1117^^^13
165 ;;30^PEDIATRICS^^MEDICINE^N^GENERAL MEDICAL CARE^1110^^^30
166 ;;48^CARDIAC SURGERY^^SURGERY^N^SURGICAL CARE^1210^^^48
167 ;;49^TRANSPLANTATION^^SURGERY^N^SURGICAL CARE^1210^^^49
168 ;;78^ANESTHESIOLOGY^^SURGERY^N^SURGICAL CARE^1210^^^78
169 ;;82^PM&R TRANSITIONAL REHAB^^REHAB MEDICINE^N^REHABILITATION MEDICINE^1113^^^82
170 ;;97^SURGICAL STEPDOWN^^SURGERY^N^SURGICAL CARE^1210^^^97
171 ;;100^SHORT STAY GRECC-NHCU^SS GRECC-NHCU^NHCU^N^NURSING HOME CARE^1430^^^1A
172 ;;101^LONG STAY GRECC-NHCU^LS GRECC-NHCU^NHCU^N^NURSING HOME CARE^1410^^^1B
173 ;;102^SHORT STAY GRECC-GEM-NHCU^SS GRECC-GEM-NH^NHCU^N^NURSING HOME CARE^1420^^^1C
174 ;;103^GRECC-GEM-REHAB^^REHAB MEDICINE^N^REHABILITATION MEDICINE^1120^^^1D
175 ;;104^GRECC-MED^^MEDICINE^N^GENERAL MEDICAL CARE^1110^^^1E
176 ;;QUIT
177ETRSP ;;PTF code^Specialty^Print Name^Service^Ask Psych^Billing Bedsection^CDR
178 ;;12^MEDICAL ICU^^MEDICINE^N^GENERAL MEDICAL CARE^1117^^
179 ;;50^GENERAL SURGERY^^SURGERY^N^SURGICAL CARE^1210^^
180 ;;51^OB/GYN^^SURGERY^N^SURGICAL CARE^1210^^
181 ;;55^EAR, NOSE, THROAT (ENT)^^SURGERY^N^SURGICAL CARE^1210^^
182 ;;56^PLASTIC SURGERY^^SURGERY^N^SURGICAL CARE^1210^^
183 ;;58^THORACIC SURGERY^^SURGERY^N^SURGICAL CARE^1210^^
184 ;;60^ORAL SURGERY^^SURGERY^N^SURGICAL CARE^1210^^
185 ;;QUIT
186 Q
187MENU ;Remove option from menu and place out of order
188 N MENU,OPTION,CHECK,IEN
189 S MENU="DGPT TOOLS MENU",OPTION="DG PTF SUFFIX EFF DATE EDIT"
190 S CHECK=$$DELETE^XPDMENU(MENU,OPTION)
191 D BMES^XPDUTL(">>> "_OPTION_" OPTION "_$S(CHECK:"REMOVED FROM ",1:"DOES NOT EXIST IN ")_MENU_" <<<")
192 D OUT^XPDMENU(OPTION,"OUT OF ORDER, DO NOT USE THIS OPTION!!!")
193 D BMES^XPDUTL(">>> "_OPTION_" OPTION PLACED OUT ORDER <<<")
194 ;Rename CDR Inquiry [DGPT CDR INQUIRY] menu
195 D BMES^XPDUTL(">>> Renaming CDR Inquiry option to MPCR Inquiry <<<")
196 S IEN=$$LKOPT^XPDMENU("DGPT CDR INQUIRY")
197 I 'IEN D Q
198 .D BMES^XPDUTL(">>> Was not able to locate CDR Inquiry option <<<")
199 .D BMES^XPDUTL(">>> PLEASE CONTACT THE NATIONAL HELP DESK <<<")
200 S DIE="^DIC(19,",DIC(0)="LX"
201 S DA=IEN,DR="1///"_"MPCR INQUIRY"_";1.1///"_"MPCR INQUIRY" D ^DIE
202 S ^DIC(19,IEN,1,1,0)="This option allows the user to view the MPCR information related"
203 S ^DIC(19,IEN,1,3,0)="as the data shown on the 'MPCR' screen of the 'Load/Edit PTF Record'"
204 D RENAME^XPDMENU("DGPT CDR INQUIRY","DGPT MPCR INQUIRY")
205 D BMES^XPDUTL(">>> CDR Inquiry Menu option Succesfully renamed <<<")
206 Q
207APTFC ;move ptf code (those < 100) into new austin ptf code field
208 N DGX,DGENTRY,DA,DR,DIE
209 D BMES^XPDUTL(">>> Populating PTF CODE field (#7) of the SPECIALTY (#42.4) file")
210 S DGX="" F S DGX=$O(^DIC(42.4,"B",DGX)) Q:DGX="" D
211 . S DGENTRY=$O(^DIC(42.4,"B",DGX,0)) I DGENTRY D
212 .. Q:$L(DGENTRY)>2 I ($E(DGENTRY,1)?1A)!($E(DGENTRY,2)?1A) Q
213 .. S DA=DGENTRY,DR="7///"_DGENTRY,DIE="^DIC(42.4," D ^DIE
214 Q
Note: See TracBrowser for help on using the repository browser.