Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGYLPOST

DGYLPOST.m

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