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

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