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