131 lines
4.3 KiB
Mathematica
131 lines
4.3 KiB
Mathematica
DGYLPOST ;ALB/CAW;Update VA Admitting Regulation/HL7 file;8/10/94<<= NOT VERIFIED >
|
|
;;5.3;Registration;**38,42**;Aug 13, 1993
|
|
EN ;
|
|
;
|
|
D INIT
|
|
D NMCHG
|
|
D CLEAN
|
|
D NEW
|
|
D INDEX
|
|
D HL7
|
|
ENQ K ADM Q
|
|
;
|
|
INIT ;Place active codes in an array
|
|
N DGI,DGC
|
|
F DGI=1:1 S DGC=$P($T(ADM+DGI),";;",2) Q:DGC="QUIT" S ADM($P(DGC,U))=DGC
|
|
Q
|
|
;
|
|
NMCHG ;Change the name of codes
|
|
;
|
|
N DGI,DIE,DA,DR
|
|
S DGI=$O(^DIC(43.4,"B","HERBICIDE/IONIZ RADIATION EXPO",0))
|
|
I DGI S DA=DGI,DR=".01///"_"AO/IR/EC EXPOSURE",DIE="^DIC(43.4," D ^DIE
|
|
S DGI=$O(^DIC(43.4,"B","RECEIPT/ELIGIBLE 38 USC 351",0))
|
|
I DGI S DA=DGI,DR=".01///"_"RECEIPT/ELIGIBLE 38 USC 1151",DIE="^DIC(43.4," D ^DIE
|
|
Q
|
|
;
|
|
CLEAN ;Clean up existing entries; add new if doesn't exit
|
|
;
|
|
N DGI,DGA,DGA1,DA,DR,DIE
|
|
S DGI="",DGA=0
|
|
F S DGI=$O(^DIC(43.4,"B",DGI)) Q:DGI']"" D
|
|
.I '$D(ADM(DGI)) D INACT Q
|
|
.S DGA=$O(^DIC(43.4,"B",DGI,0))
|
|
.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,"
|
|
.D ^DIE
|
|
.F S DGA=$O(^DIC(43.4,"B",DGI,DGA)) Q:'DGA D INACT
|
|
.K ADM(DGI)
|
|
Q
|
|
;
|
|
INACT ;Inactivate entry
|
|
;
|
|
S DGA1=DGA
|
|
S:'DGA DGA1=$O(^DIC(43.4,"B",DGI,0))
|
|
S $P(^DIC(43.4,DGA1,0),U,4)=1
|
|
F S DGA1=$O(^DIC(43.4,"B",DGI,DGA1)) Q:'DGA1 S $P(^DIC(43.4,DGA1,0),U,4)=1
|
|
Q
|
|
;
|
|
NEW ;Add new entry
|
|
;
|
|
N DIC,DLAYGO,DGI,X,Y
|
|
S DGI=""
|
|
W !,"Adding entries to the VA ADMITTING REGULATION (43.4) file."
|
|
F S DGI=$O(ADM(DGI)) Q:DGI']"" D
|
|
.S DIC(0)="L",DLAYGO=43.4,DIC="^DIC(43.4,"
|
|
.S X=$P(ADM(DGI),U)
|
|
.S DIC("DR")="2////"_$P(ADM(DGI),"^",3)_";4////"_$P(ADM(DGI),"^",4)_";6////"_$P(ADM(DGI),U,6)
|
|
.D FILE^DICN,MESA
|
|
Q
|
|
;
|
|
MESA ;Message to add new entry
|
|
W !?8,"...adding "_$P(ADM(DGI),U)_" to file..."
|
|
Q
|
|
;
|
|
ADM ;List of active VA ADMITTING REGULATIONS
|
|
;;ACTIVE PSYCHOSIS^^17.33^0^^1
|
|
;;ACTIVE SERVICE^^17.46(b)^0^^2
|
|
;;ALLIED VETERANS^^17.46(b)^0^^3
|
|
;;AO/IR/EC EXPOSURE^^17.47(a)(5)^0^^4
|
|
;;CATEGORY A INCOME VETERANS^^17.47(a)(7)^0^^5
|
|
;;CATEGORY C INCOME VETERANS^^17.47(d)^0^^6
|
|
;;CHAMPVA^^17.54^0^^7
|
|
;;COMMUNITY NURSING HOME CARE^^17.51^0^^8
|
|
;;CZECH AND POLISH VETERANS^^17.55^0^^9
|
|
;;DISCHARGED FOR DISABILITY^^17.47(a)(2)^0^^10
|
|
;;DOMICILIARY CARE^^17.47(e)(1)^0^^11
|
|
;;ELIGIBLE FOR STATE MEDICAID^^17.48(d)(1)(i)^0^^12
|
|
;;EMERGENCY FOR PUBLIC^^17.46(c)(1)^0^^13
|
|
;;FEE SVC FOR MB,WW1,A&A,HB^^17.50b(a)(2)(iii)^0^^14
|
|
;;FEE SVC FOR OPT/NSC^^17.50b(a)(2)(ii)^0^^15
|
|
;;FEE SVC FOR VETS 50% OR MORE^^17.50b(a)(2)(i)^0^^16
|
|
;;FORMER PRISONER OF WAR^^17.47(a)(4)^0^^17
|
|
;;HOSP/NH IN PHILLIPINES (NONVA)^^17.38^0^^18
|
|
;;IN RECEIPT OF VA PENSION^^17.47(a)(7)^0^^19
|
|
;;INELIGIBLE/PRESUMED DISCHARGE^^17.46(c)(2)^0^^20
|
|
;;NON-VA (AK,HA,VI,TERR)^^17.50b(a)(6)^0^^21
|
|
;;NON-VA (DISABILITY DISCHARGED)^^17.50b(a)(1)(ii)^0^^22
|
|
;;NON-VA (P&T DISABILITY)^^17.50b(a)(1)(iii)^0^^23
|
|
;;NON-VA EMERGENCY (WHILE IN VA)^^17.50b(a)(3)^0^^24
|
|
;;NON-VA FOR ADJUNCT CONDITION^^17.50b(a)(1)(iv)^0^^25
|
|
;;NON-VA FOR FEMALE VETERANS^^17.50b(a)(4)^0^^26
|
|
;;NON-VA FOR SC DISABILITY^^17.50b(a)(1)(i)^0^^27
|
|
;;NON-VA FOR VOCATIONAL REHAB^^17.50b(a)(1)(v)^0^^28
|
|
;;NON-VA/UNAUTH FOR SC COND^^17.80(a)(1)^0^^29
|
|
;;NONVA EMERG DURING AUTH TRAVEL^^17.50b(a)(8)^0^^30
|
|
;;NONVA INDEP VA OPT CLINICS^^17.50b(a)(9)^0^^31
|
|
;;NONVA/UNAUTH (ADJUNCT COND)^^17.80(a)(2)^0^^32
|
|
;;NONVA/UNAUTH (P&T DISABILITY)^^17.80(a)(3)^0^^33
|
|
;;OBSERVATION & EXAMINATION^^17.45^0^^34
|
|
;;OPT DENTAL (POW >90 DAYS)^^17.50(a)(7)^0^^35
|
|
;;OTHER FEDERAL AGENCIES^^17.46(b)^0^^36
|
|
;;PRESUMPTION OF SC^^17.35(b)^0^^37
|
|
;;RECEIPT/ELIGIBLE 38 USC 1151^^17.47(a)(3)^0^^38
|
|
;;RESEARCH PATIENTS - VETERANS^^17.47Z^0^^39
|
|
;;RESEARCH VOLUNTEERS (NONVET)^^17.46(c)^0^^40
|
|
;;SAW, MB, & WW1^^17.47(a)(6)^0^^41
|
|
;;SC VET FOR ANY CONDITION^^17.47(a)(1)^0^^42
|
|
;;SHARING AGREEMENT^^17.46(d)^0^^43
|
|
;;STATE NH, DOM OR HOSP.^^17.1666d^0^^44
|
|
;;VA EMPLOYEES/FAMILY^^17.46(c)(3)^0^^45
|
|
;;VOCATIONAL REHABILITATION^^17.80(a)(4)^0^^46
|
|
;;QUIT
|
|
;
|
|
HL7 ; Update HL7 version and segment files
|
|
;
|
|
N DA,DIC,DIE,DLAYGO,HLVER,X,Y
|
|
S HLVER=$O(^HL(771.5,"B",2.2,0)) I HLVER G HL7713
|
|
K DD,DO S DIC="^HL(771.5,",DIC(0)="L",DLAYGO=771.5,X=2.2 D FILE^DICN
|
|
S HLVER=+Y,DA=$O(^HL(770,"B","EDR-MAS",0))
|
|
I DA S DIE="^HL(770,",DR="7///"_+Y D ^DIE
|
|
;
|
|
HL7713 I $D(^HL(771.3,"B","PV2")) Q
|
|
K DD,DO S DIC="^HL(771.3,",DIC(0)="L",DLAYGO=771.3,X="PV2" D FILE^DICN S DA=+Y
|
|
S DIE=DIC,DA=+Y,DR="2////^S X=""Patient Visit - Additional"";3////^S X=HLVER"
|
|
D ^DIE
|
|
Q
|
|
;
|
|
INDEX ; Reindex VA ADMITTING REGULATION file
|
|
N DIK
|
|
S DIK="^DIC(43.4,",DIK(1)="6" D ENALL^DIK
|
|
Q
|