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

BCQMUTL.m

Go to the documentation of this file. 
  1. BCQMUTL ; IHS/OIT/FBD - MAPPER UTILITIES ;05/07/2018 07:49;FS
  1.  ;;1.0;IHS CODE MAPPING;;MAY 07, 2018;Build 21
  1.  ;
  1. TXICU(V) ;EP - IS THIS ADMISSION A TRANSFER TO AN ICU?
  1.  I $G(V)="" Q 0
  1.  ;did this admission tx to a ward that is an ICU
  1.  NEW X,Y,Z,D
  1.  S D=$O(^DGPM("AVISIT",V,0))
  1.  I D="" Q 0  ;no admission data to look at
  1.  ;check each icu ward and whether the patient transferred into it
  1.  S Y=0,X=0
  1.  F  S X=$O(^DIC(42.1,X)) Q:X'=+X!(Y)  D
  1.  .S W=$O(^BDGWD("B",X,0))
  1.  .I W="" Q
  1.  .I $$GET1^DIQ(9009016.5,W,101,"I")'=1 Q  ;NOT AN ICU
  1.  .I $$FINDWARD($P(^AUPNVSIT(V,0),U,5),D,X,2) S Y=1
  1.  Q Y
  1. FINDWARD(DF,ADM,WARD,TT) ;-- find out if the ward is what they are looking for based on data
  1.  N WDA,WIEN,TRAN,WD,RES
  1.  S RES=0
  1.  S WDA=0 F  S WDA=$O(^DGPM("APCA",DF,ADM,WDA)) Q:'WDA!($G(RES))  D
  1.  . S WIEN=0 F  S WIEN=$O(^DGPM("APCA",DF,ADM,WDA,WIEN)) Q:'WIEN!($G(RES))  D
  1.  .. S TRAN=$P($G(^DGPM(WIEN,0)),U,2)
  1.  .. Q:TRAN'=TT
  1.  .. S WD=$$GET1^DIQ(405,WIEN,.06,"I")
  1.  .. I WD[WARD S RES=WD Q
  1.  Q $G(RES)
  1.  ;
  1. ICU(V) ;EP - IS THE WARD AN ICU
  1.  I $G(V)="" Q 0
  1.  NEW D,W
  1.  S D=$O(^DGPM("AVISIT",V,0))
  1.  I D="" Q 0
  1.  S W=$$GET1^DIQ(405,D,.06,"I")
  1.  I W="" Q 0
  1.  S W=$O(^BDGWD("B",W,0))
  1.  I W="" Q 0
  1.  S W=$$GET1^DIQ(9009016.5,W,101,"I")
  1.  Q W
  1. FACTYPE(V) ;EP - RETURN FACILITY TYPE
  1.  Q $$GET1^DIQ(4,V,13)
  1. HOSP(V) ;EP - IS THIS A HOSPITAL FACILITY TYPE?
  1.  I $G(V)="" Q 0
  1.  I '$D(^AUPNVSIT(V,0)) Q 0
  1.  NEW A
  1.  S A=$P(^AUPNVSIT(V,0),U,6)
  1.  I 'A Q 0
  1.  I '$D(^DIC(4,A,0)) Q 0
  1.  S A=$$FACTYPE(A)
  1.  I A="HOSPITAL" Q 1
  1.  Q 0
  1. NURSEVAL(CLIN,PROV,TIU) ;EP - IS THIS A NURSE VISIT?
  1.  I 'TIU Q 0  ;no tiu note
  1.  I CLIN=45 Q 1
  1.  I CLIN=79 Q 1
  1.  I CLIN="B4" Q 1
  1.  I PROV="01" Q 1
  1.  I PROV="05" Q 1
  1.  I PROV=13 Q 1
  1.  I PROV=14 Q 1
  1.  I PROV=32 Q 1
  1.  Q 0
  1.  ;
  1. NHBRL(V) ;EP- IS THERE BOTH RIGHT AND LEFT NEWBORN HEARING?
  1.  I '$G(V) Q ""
  1.  NEW X,Y,Z,BCQMR,BCQML
  1.  S (BCQMR,BCQML)=0
  1.  S X=0 F  S X=$O(^AUPNVXAM("AD",V,X)) Q:X'=+X  D
  1.  .I $$GET1^DIQ(9999999.15,$$GET1^DIQ(9000010.13,X,.01,"I"),.02)="39" S BCQMR=1
  1.  .I $$GET1^DIQ(9999999.15,$$GET1^DIQ(9000010.13,X,.01,"I"),.02)="38" S BCQML=1
  1.  I BCQMR+BCQML=2 Q 1
  1.  Q 0
  1. ESTIM(V) ;EP - IS THIS AN ESTIMATE?
  1.  ;does a ";" piece of V contain qualifier "estimated"
  1.  NEW X,Y,Z
  1.  S Z=0
  1.  F X=1:1 S Y=$P(V,";",X) Q:Y=""  I $$UP^XLFSTR(Y)="ESTIMATED" S Z=1
  1.  Q Z
  1. H72(V) ;EP - WAS THIS H visit adm date w/in 72 hours of a discharge date
  1.  I $G(V)="" Q ""
  1.  I '$D(^AUPNVSIT(V,0)) Q ""
  1.  I $P(^AUPNVSIT(V,0),U,7)'="H" Q ""
  1.  NEW X,Y,Z,A,P,D,G
  1.  S P=$P(^AUPNVSIT(V,0),U,5)
  1.  S G=0
  1.  S A=$$VDTM^APCLV(V)  ;get visit/admit date& time
  1.  S D=0 F  S D=$O(^AUPNVSIT("AAH",P,D)) Q:D=""  S X=0 F  S X=$O(^AUPNVSIT("AAH",P,D,X)) Q:X=""!(G)  D
  1.  .Q:X=V  ;same visit
  1.  .S E=$$DDTM^APCLV(X)  ;get disharge date/time
  1.  .S Y=$$FMDIFF^XLFDT(A,E,2)
  1.  .Q:Y>259200
  1.  .Q:Y<0
  1.  .S G=1
  1.  .Q
  1.  Q G
  1. AGEV(V) ;EP - age of patient on this visit
  1.  I $G(V)="" Q ""
  1.  I '$D(^AUPNVSIT(V,0)) Q ""  ;no visit
  1.  NEW P,A
  1.  S P=$P(^AUPNVSIT(V,0),U,5)
  1.  I 'P Q ""
  1.  Q $$AGE^AUPNPAT(P,$$VD^APCLV(V))
  1. EKGFINDL() ;PEP - return EKG finding loinc
  1.  Q "8601-7"