- 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 Jan 18, 2025@04:00:55 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