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