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

BHSMEAIP.m

Go to the documentation of this file. 
  1. BHSMEAIP ;IHS/CIA/MGH - Health Summary for Inpt Measurements ;21-Apr-2014 17:24;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**7,9**;March 17, 2006;Build 16
  1.  ;===================================================================
  1.  ;Taken from APCHS2
  1.  ; IHS/TUCSON/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**2,3**;JUN 24, 1997
  1.  ;IHS/CMI/LAB - patch 2 fixed AGE subroutine
  1.  ;IHS/CMI/LAB - patch 3 new imm package
  1.  ;Creation of VA health summary components from IHS health summary components
  1.  ;for V measurement file and immunizations
  1.  ;Patch 2 for patch 16 and CVS changes
  1.  ;Patch 3 to fix a bug in the display
  1.  ;Patch 4 added qualifiers for vitals
  1.  ;Patch 5 fixed a bug with items with / in them
  1.  ;
  1. INPMEAS ; ******************** MEASUREMENTS INPT ********** 9000010.01 *******
  1.  ; <SETUP>
  1.  N BHSPAT,BHSNDM,Y,ARRAY,BHSVST,BHSVDTE,VCNT,BHSINPV,BHSINVDT,APCHMEAS,BHSINPS,X,C,VIEN
  1.  S BHSPAT=DFN
  1.  Q:'$D(^AUPNVMSR("AA",BHSPAT))
  1.  ; <DISPLAY>
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  W !
  1.  NEW X,Y,V
  1.  S VIEN="",VCNT=0
  1.  S BHSNDM=GMTSNDM-1
  1.  S BHSINVDT=0 F  S BHSINVDT=$O(^AUPNVSIT("AAH",BHSPAT,BHSINVDT)) Q:BHSINVDT=""!(VCNT>BHSNDM)  D
  1.  .S VIEN=0 F  S VIEN=$O(^AUPNVSIT("AAH",BHSPAT,BHSINVDT,VIEN)) Q:VIEN=""!(VCNT>BHSNDM)  D
  1.  ..Q:'$D(^AUPNVSIT(VIEN,0))
  1.  ..Q:$P(^AUPNVSIT(VIEN,0),U,3)="C"  ;don't count contract visits
  1.  ..S BHSINPB=$P($P(^AUPNVSIT(VIEN,0),U,1),".")  ;admission date of last H visit
  1.  ..S BHSINPS=9999999-BHSINPB
  1.  ..S BHSINPD=$$DSCHDATE^APCLV(VIEN)  ;get discharge date
  1.  ..I BHSINPD="" S BHSINPD=DT  ;if no discharge date, set to DT as this means the patient is in-house
  1.  ..S VCNT=VCNT+1
  1.  ..D GET(BHSINPD,BHSINPB)
  1.  D MEASDSP
  1.  ; <CLEANUP>
  1. MEASX K BHSDFN,BHSMT,BHSMT2,BHSMT3,BHSDFN,BHSND2,BHSDAT,BHSMIEN,BHSM,BHSEVD,BHSMDSP,BHSIVD,BHSVSIT,BHSX,BHSWP,APCHWP,APCHMEAS
  1.  Q
  1.  ;Get the visit(s) to check on
  1. GET(BHSINPD,BHSINPB) ;
  1.  ;loop through all visits from adm date to discharge date (or DT) and display measurements from
  1.  ;H and I visits
  1.  S BHSIVD=(9999999-BHSINPD-1)_".9999"
  1.  F  S BHSIVD=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD)) Q:$P(BHSIVD,".")>BHSINPS!(BHSIVD="")  D
  1.  .S BHSVSIT=0 F  S BHSVSIT=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD,BHSVSIT)) Q:BHSVSIT'=+BHSVSIT  D
  1.  ..Q:'$D(^AUPNVSIT(BHSVSIT,0))
  1.  ..Q:"HI"'[$P(^AUPNVSIT(BHSVSIT,0),U,7)  ;only H and I
  1.  ..S BHSM=0 F  S BHSM=$O(^AUPNVMSR("AD",BHSVSIT,BHSM)) Q:BHSM=""  D
  1.  ...;GET EVENT DATE/TIME OR VISIT DATE/TIME
  1.  ...Q:'$D(^AUPNVMSR(BHSM,0))
  1.  ...Q:$P(^AUPNVMSR(BHSM,0),U,1)=""
  1.  ...Q:$P($G(^AUPNVMSR(BHSM,2)),U,1)  ;entered in error so skip it
  1.  ...S BHSEVD=+$E($P($G(^AUPNVMSR(BHSM,12)),U,1),1,12)  ;STRIP OFF SECONDS IF ENTERED PER SUSAN AND MARY ANN EMAIL
  1.  ...I BHSEVD=""!(BHSEVD=0) S BHSEVD=$P(^AUPNVSIT(BHSVSIT,0),U,1)  ;visit date/time if no event date time
  1.  ...I BHSMDSP="D" S APCHMEAS(BHSEVD,$$VAL^XBDIQ1(9000010.01,BHSM,.01),BHSM)=""
  1.  ...I BHSMDSP="T" S APCHMEAS($$VAL^XBDIQ1(9000010.01,BHSM,.01),BHSEVD,BHSM)=""
  1.  Q
  1. MEASDSP ;
  1.  I BHSMDSP="T" G MEASDSPT  ;display by type
  1.  S BHSIVD="" F  S BHSIVD=$O(APCHMEAS(BHSIVD),-1) Q:BHSIVD=""!($D(GMTSQIT))  D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !,?2,$$DT(BHSIVD)
  1.  .S BHSMT="" F  S BHSMT=$O(APCHMEAS(BHSIVD,BHSMT)) Q:BHSMT=""!($D(GMTSQIT))  D
  1.  ..S BHSDFN=0 F  S BHSDFN=$O(APCHMEAS(BHSIVD,BHSMT,BHSDFN)) Q:BHSDFN=""!($D(GMTSQIT))  D MEASDSP1
  1.  Q
  1. MEASDSPT ;
  1.  ;
  1.  S BHSMT="" F  S BHSMT=$O(APCHMEAS(BHSMT)) Q:BHSMT=""  D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !?1,$S(BHSMT="O2":"O2 Sat",1:BHSMT)
  1.  .S BHSIVD="" F  S BHSIVD=$O(APCHMEAS(BHSMT,BHSIVD),-1) Q:BHSIVD=""!($D(GMTSQIT))  D
  1.  ..S BHSDFN=0 F  S BHSDFN=$O(APCHMEAS(BHSMT,BHSIVD,BHSDFN)) Q:BHSDFN=""!($D(GMTSQIT))  D
  1.  ...D MEASDSP2
  1.  Q
  1. DT(D) ;
  1.  NEW A
  1.  S A=$$FMTE^XLFDT(D,5)
  1.  S A=$P(A,"@",2),A=$P(A,":",1,2)
  1.  NEW B
  1.  S B=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
  1.  Q B_$S(A]"":"@",1:"")_A
  1.  ;
  1. MEASDSP1 ;
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W ?21,$S(BHSMT="O2":"O2 Sat",1:BHSMT) D REST
  1.  Q
  1. MEASDSP2 ;
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W:GMTSNPG ?1,$S(BHSMT="O2":"O2 Sat",1:BHSMT)
  1.  W ?9,$$DT(BHSIVD)
  1.  D REST
  1.  Q
  1. REST ;
  1.  N VALUE,PREG
  1.  S VALUE=$P(^AUPNVMSR(BHSDFN,0),U,4)
  1.  S VALUE=+$J(VALUE,0,2)
  1.  I BHSMT="BMI" D
  1.  .S PREG=$$PREG^BHSMEA(DFN,"",BHSDFN)
  1.  .I PREG=1 S VALUE=VALUE_"*"
  1.  W ?29,VALUE
  1.  I $$VAL^XBDIQ1(9000010.01,BHSDFN,.01)="O2" D
  1.  .Q:$P(^AUPNVMSR(BHSDFN,0),U,10)=""
  1.  .W ?41,"Supplemental O2: ",$P(^AUPNVMSR(BHSDFN,0),U,10),!
  1.  I '$O(^AUPNVMSR(BHSDFN,5,0)) W ! Q   ;no qualifiers
  1.  S C=0,X=0 F  S X=$O(^AUPNVMSR(BHSDFN,5,X)) Q:X'=+X  S C=C+1
  1.  W ?41,"Qualifier"_$S(C>1:"s",1:""),":"
  1.  S BHSX=0,X="" F  S BHSX=$O(^AUPNVMSR(BHSDFN,5,BHSX)) Q:BHSX'=+BHSX  S Y=$P($G(^AUPNVMSR(BHSDFN,5,BHSX,0)),U) I Y S X=X_$S(X]"":", ",1:"")_$P($G(^GMRD(120.52,Y,0)),U,1)
  1.  K APCHWP
  1.  D WP^APCHS82(X,23)
  1.  S BHSX=0,C=0 F  S BHSX=$O(APCHWP(BHSX)) Q:BHSX'=+BHSX!($D(GMTSQIT))  D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .S C=C+1
  1.  .I C>1 W !
  1.  .W ?53,APCHWP(BHSX)
  1.  W !
  1.  Q
  1.  ;
  1. INPMEASD ;EP
  1.  S BHSMDSP="D"
  1.  G INPMEAS
  1.  Q
  1. INPMEAST ;EP
  1.  S BHSMDSP="T"
  1.  G INPMEAS
  1.  Q