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

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

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1DGYLPOST ;ALB/CAW;Update VA Admitting Regulation/HL7 file;8/10/94<<= NOT VERIFIED >
2 ;;5.3;Registration;**38,42**;Aug 13, 1993
3EN ;
4 ;
5 D INIT
6 D NMCHG
7 D CLEAN
8 D NEW
9 D INDEX
10 D HL7
11ENQ K ADM Q
12 ;
13INIT ;Place active codes in an array
14 N DGI,DGC
15 F DGI=1:1 S DGC=$P($T(ADM+DGI),";;",2) Q:DGC="QUIT" S ADM($P(DGC,U))=DGC
16 Q
17 ;
18NMCHG ;Change the name of codes
19 ;
20 N DGI,DIE,DA,DR
21 S DGI=$O(^DIC(43.4,"B","HERBICIDE/IONIZ RADIATION EXPO",0))
22 I DGI S DA=DGI,DR=".01///"_"AO/IR/EC EXPOSURE",DIE="^DIC(43.4," D ^DIE
23 S DGI=$O(^DIC(43.4,"B","RECEIPT/ELIGIBLE 38 USC 351",0))
24 I DGI S DA=DGI,DR=".01///"_"RECEIPT/ELIGIBLE 38 USC 1151",DIE="^DIC(43.4," D ^DIE
25 Q
26 ;
27CLEAN ;Clean up existing entries; add new if doesn't exit
28 ;
29 N DGI,DGA,DGA1,DA,DR,DIE
30 S DGI="",DGA=0
31 F S DGI=$O(^DIC(43.4,"B",DGI)) Q:DGI']"" D
32 .I '$D(ADM(DGI)) D INACT Q
33 .S DGA=$O(^DIC(43.4,"B",DGI,0))
34 .S DA=DGA,DR="2///"_$P(ADM(DGI),U,3)_";4///"_$P(ADM(DGI),U,4)_";6///"_$P(ADM(DGI),U,6),DIE="^DIC(43.4,"
35 .D ^DIE
36 .F S DGA=$O(^DIC(43.4,"B",DGI,DGA)) Q:'DGA D INACT
37 .K ADM(DGI)
38 Q
39 ;
40INACT ;Inactivate entry
41 ;
42 S DGA1=DGA
43 S:'DGA DGA1=$O(^DIC(43.4,"B",DGI,0))
44 S $P(^DIC(43.4,DGA1,0),U,4)=1
45 F S DGA1=$O(^DIC(43.4,"B",DGI,DGA1)) Q:'DGA1 S $P(^DIC(43.4,DGA1,0),U,4)=1
46 Q
47 ;
48NEW ;Add new entry
49 ;
50 N DIC,DLAYGO,DGI,X,Y
51 S DGI=""
52 W !,"Adding entries to the VA ADMITTING REGULATION (43.4) file."
53 F S DGI=$O(ADM(DGI)) Q:DGI']"" D
54 .S DIC(0)="L",DLAYGO=43.4,DIC="^DIC(43.4,"
55 .S X=$P(ADM(DGI),U)
56 .S DIC("DR")="2////"_$P(ADM(DGI),"^",3)_";4////"_$P(ADM(DGI),"^",4)_";6////"_$P(ADM(DGI),U,6)
57 .D FILE^DICN,MESA
58 Q
59 ;
60MESA ;Message to add new entry
61 W !?8,"...adding "_$P(ADM(DGI),U)_" to file..."
62 Q
63 ;
64ADM ;List of active VA ADMITTING REGULATIONS
65 ;;ACTIVE PSYCHOSIS^^17.33^0^^1
66 ;;ACTIVE SERVICE^^17.46(b)^0^^2
67 ;;ALLIED VETERANS^^17.46(b)^0^^3
68 ;;AO/IR/EC EXPOSURE^^17.47(a)(5)^0^^4
69 ;;CATEGORY A INCOME VETERANS^^17.47(a)(7)^0^^5
70 ;;CATEGORY C INCOME VETERANS^^17.47(d)^0^^6
71 ;;CHAMPVA^^17.54^0^^7
72 ;;COMMUNITY NURSING HOME CARE^^17.51^0^^8
73 ;;CZECH AND POLISH VETERANS^^17.55^0^^9
74 ;;DISCHARGED FOR DISABILITY^^17.47(a)(2)^0^^10
75 ;;DOMICILIARY CARE^^17.47(e)(1)^0^^11
76 ;;ELIGIBLE FOR STATE MEDICAID^^17.48(d)(1)(i)^0^^12
77 ;;EMERGENCY FOR PUBLIC^^17.46(c)(1)^0^^13
78 ;;FEE SVC FOR MB,WW1,A&A,HB^^17.50b(a)(2)(iii)^0^^14
79 ;;FEE SVC FOR OPT/NSC^^17.50b(a)(2)(ii)^0^^15
80 ;;FEE SVC FOR VETS 50% OR MORE^^17.50b(a)(2)(i)^0^^16
81 ;;FORMER PRISONER OF WAR^^17.47(a)(4)^0^^17
82 ;;HOSP/NH IN PHILLIPINES (NONVA)^^17.38^0^^18
83 ;;IN RECEIPT OF VA PENSION^^17.47(a)(7)^0^^19
84 ;;INELIGIBLE/PRESUMED DISCHARGE^^17.46(c)(2)^0^^20
85 ;;NON-VA (AK,HA,VI,TERR)^^17.50b(a)(6)^0^^21
86 ;;NON-VA (DISABILITY DISCHARGED)^^17.50b(a)(1)(ii)^0^^22
87 ;;NON-VA (P&T DISABILITY)^^17.50b(a)(1)(iii)^0^^23
88 ;;NON-VA EMERGENCY (WHILE IN VA)^^17.50b(a)(3)^0^^24
89 ;;NON-VA FOR ADJUNCT CONDITION^^17.50b(a)(1)(iv)^0^^25
90 ;;NON-VA FOR FEMALE VETERANS^^17.50b(a)(4)^0^^26
91 ;;NON-VA FOR SC DISABILITY^^17.50b(a)(1)(i)^0^^27
92 ;;NON-VA FOR VOCATIONAL REHAB^^17.50b(a)(1)(v)^0^^28
93 ;;NON-VA/UNAUTH FOR SC COND^^17.80(a)(1)^0^^29
94 ;;NONVA EMERG DURING AUTH TRAVEL^^17.50b(a)(8)^0^^30
95 ;;NONVA INDEP VA OPT CLINICS^^17.50b(a)(9)^0^^31
96 ;;NONVA/UNAUTH (ADJUNCT COND)^^17.80(a)(2)^0^^32
97 ;;NONVA/UNAUTH (P&T DISABILITY)^^17.80(a)(3)^0^^33
98 ;;OBSERVATION & EXAMINATION^^17.45^0^^34
99 ;;OPT DENTAL (POW >90 DAYS)^^17.50(a)(7)^0^^35
100 ;;OTHER FEDERAL AGENCIES^^17.46(b)^0^^36
101 ;;PRESUMPTION OF SC^^17.35(b)^0^^37
102 ;;RECEIPT/ELIGIBLE 38 USC 1151^^17.47(a)(3)^0^^38
103 ;;RESEARCH PATIENTS - VETERANS^^17.47Z^0^^39
104 ;;RESEARCH VOLUNTEERS (NONVET)^^17.46(c)^0^^40
105 ;;SAW, MB, & WW1^^17.47(a)(6)^0^^41
106 ;;SC VET FOR ANY CONDITION^^17.47(a)(1)^0^^42
107 ;;SHARING AGREEMENT^^17.46(d)^0^^43
108 ;;STATE NH, DOM OR HOSP.^^17.1666d^0^^44
109 ;;VA EMPLOYEES/FAMILY^^17.46(c)(3)^0^^45
110 ;;VOCATIONAL REHABILITATION^^17.80(a)(4)^0^^46
111 ;;QUIT
112 ;
113HL7 ; Update HL7 version and segment files
114 ;
115 N DA,DIC,DIE,DLAYGO,HLVER,X,Y
116 S HLVER=$O(^HL(771.5,"B",2.2,0)) I HLVER G HL7713
117 K DD,DO S DIC="^HL(771.5,",DIC(0)="L",DLAYGO=771.5,X=2.2 D FILE^DICN
118 S HLVER=+Y,DA=$O(^HL(770,"B","EDR-MAS",0))
119 I DA S DIE="^HL(770,",DR="7///"_+Y D ^DIE
120 ;
121HL7713 I $D(^HL(771.3,"B","PV2")) Q
122 K DD,DO S DIC="^HL(771.3,",DIC(0)="L",DLAYGO=771.3,X="PV2" D FILE^DICN S DA=+Y
123 S DIE=DIC,DA=+Y,DR="2////^S X=""Patient Visit - Additional"";3////^S X=HLVER"
124 D ^DIE
125 Q
126 ;
127INDEX ; Reindex VA ADMITTING REGULATION file
128 N DIK
129 S DIK="^DIC(43.4,",DIK(1)="6" D ENALL^DIK
130 Q
Note: See TracBrowser for help on using the repository browser.