APCHS2I ; IHS/CMI/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; 03 Jul 2012 7:20 PM
;;2.0;IHS PCC SUITE;**9**;MAY 14, 2009;Build 3
;
INPMEAS ; ******************** MEASUREMENTS * 9000010.01 *******
; <SETUP>
Q:'$D(^AUPNVMSR("AA",APCHSPAT))
;get last/latest Hospital Stay admission date
NEW APCHINPB,APCHINPV,APCHINPD,APCHINPS,APCHVSIT,APCHM,APCHMEAS,APCHEVD,APCHM,APCHSX,APCHSMT,APCHSDFN ;adm date ivd, ien, dd ivd
S APCHINPV=$$LASTHV(APCHSPAT) ;get ien of latest H visit that is not contract health
I 'APCHINPV Q ;no hospital stays so don't bother
S APCHINPB=$P($P(^AUPNVSIT(APCHINPV,0),U,1),".") ;admission date of last H visit
S APCHINPS=9999999-APCHINPB
S APCHINPD=$$DSCHDATE^APCLV(APCHINPV) ;get discharge date
I APCHINPD="" S APCHINPD=DT ;if no discharge date, set to DT as this means the patient is in-house
X APCHSBRK
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT)
;loop through all visits from adm date to discharge date (or DT) and display measurements from
;H and I visits
S APCHSIVD=(9999999-APCHINPD-1)_".9999"
F S APCHSIVD=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD)) Q:$P(APCHSIVD,".")>APCHINPS!(APCHSIVD="") D
.S APCHVSIT=0 F S APCHVSIT=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD,APCHVSIT)) Q:APCHVSIT'=+APCHVSIT D
..Q:'$D(^AUPNVSIT(APCHVSIT,0))
..Q:"HI"'[$P(^AUPNVSIT(APCHVSIT,0),U,7) ;only H and I
..S APCHM=0 F S APCHM=$O(^AUPNVMSR("AD",APCHVSIT,APCHM)) Q:APCHM="" D
...;GET EVENT DATE/TIME OR VISIT DATE/TIME
...Q:'$D(^AUPNVMSR(APCHM,0))
...Q:$P(^AUPNVMSR(APCHM,0),U,1)=""
...Q:$P($G(^AUPNVMSR(APCHM,2)),U,1) ;entered in error so skip it
...S APCHEVD=+$E($P($G(^AUPNVMSR(APCHM,12)),U,1),1,12) ;STRIP OFF SECONDS IF ENTERED PER SUSAN AND MARY ANN EMAIL
...I APCHEVD=""!(APCHEVD=0) S APCHEVD=$P(^AUPNVSIT(APCHINPV,0),U,1) ;visit date/time if no event date time
...I APCHMDSP="D" S APCHMEAS(APCHEVD,$$VAL^XBDIQ1(9000010.01,APCHM,.01),APCHM)=""
...I APCHMDSP="T" S APCHMEAS($$VAL^XBDIQ1(9000010.01,APCHM,.01),APCHEVD,APCHM)=""
;now display them
D MEASDSP
; <CLEANUP>
MEASX K APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT,APCHMEAS
Q
INPMEASD ;EP
S APCHMDSP="D"
G INPMEAS
INPMEAST ;EP
S APCHMDSP="T"
G INPMEAS
MEASDSP ;
I APCHMDSP="T" G MEASDSPT ;display by type
S APCHSIVD="" F S APCHSIVD=$O(APCHMEAS(APCHSIVD),-1) Q:APCHSIVD=""!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT) W !,?2,$$DT(APCHSIVD)
.S APCHMT="" F S APCHMT=$O(APCHMEAS(APCHSIVD,APCHMT)) Q:APCHMT=""!($D(APCHSQIT)) D
..S APCHSDFN=0 F S APCHSDFN=$O(APCHMEAS(APCHSIVD,APCHMT,APCHSDFN)) Q:APCHSDFN=""!($D(APCHSQIT)) D MEASDSP1
Q
MEASDSPT ;
;
S APCHMT="" F S APCHMT=$O(APCHMEAS(APCHMT)) Q:APCHMT="" D
.X APCHSCKP Q:$D(APCHSQIT)
.W !?1,$S(APCHMT="O2":"O2 Sat",1:APCHMT)
.S APCHSIVD="" F S APCHSIVD=$O(APCHMEAS(APCHMT,APCHSIVD),-1) Q:APCHSIVD=""!($D(APCHSQIT)) D
..S APCHSDFN=0 F S APCHSDFN=$O(APCHMEAS(APCHMT,APCHSIVD,APCHSDFN)) Q:APCHSDFN=""!($D(APCHSQIT)) 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 ;
X APCHSCKP Q:$D(APCHSQIT)
W ?21,$S(APCHMT="O2":"O2 Sat",1:APCHMT) D REST
Q
MEASDSP2 ;
X APCHSCKP Q:$D(APCHSQIT)
W:APCHSNPG ?1,$S(APCHMT="O2":"O2 Sat",1:APCHMT)
W ?9,$$DT(APCHSIVD)
D REST
Q
REST ;
W ?29,$P(^AUPNVMSR(APCHSDFN,0),U,4)
I $$VAL^XBDIQ1(9000010.01,APCHSDFN,.01)="O2" D
.Q:$P(^AUPNVMSR(APCHSDFN,0),U,10)=""
.W ?41,"Supplemental O2: ",$P(^AUPNVMSR(APCHSDFN,0),U,10),!
I '$O(^AUPNVMSR(APCHSDFN,5,0)) W ! Q ;no qualifiers
S C=0,X=0 F S X=$O(^AUPNVMSR(APCHSDFN,5,X)) Q:X'=+X S C=C+1
W ?41,"Qualifier"_$S(C>1:"s",1:""),":"
S APCHSX=0,X="" F S APCHSX=$O(^AUPNVMSR(APCHSDFN,5,APCHSX)) Q:APCHSX'=+APCHSX S Y=$P($G(^AUPNVMSR(APCHSDFN,5,APCHSX,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 APCHX=0,C=0 F S APCHX=$O(APCHWP(APCHX)) Q:APCHX'=+APCHX!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT)
.S C=C+1
.I C>1 W !
.W ?53,APCHWP(APCHX)
W !
Q
LASTHV(P) ;get last H visit that is not contract
NEW X,Y,V
S V=""
S X=0 F S X=$O(^AUPNVSIT("AAH",P,X)) Q:X'=+X!(V) D
.S Y=0 F S Y=$O(^AUPNVSIT("AAH",P,X,Y)) Q:Y'=+Y D
..Q:'$D(^AUPNVSIT(Y,0))
..Q:$P(^AUPNVSIT(Y,0),U,3)="C" ;don't count contract visits
..S V=Y
..Q
Q V
APCHS2I ; IHS/CMI/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; 03 Jul 2012 7:20 PM
+1 ;;2.0;IHS PCC SUITE;**9**;MAY 14, 2009;Build 3
+2 ;
INPMEAS ; ******************** MEASUREMENTS * 9000010.01 *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVMSR("AA",APCHSPAT))
QUIT
+3 ;get last/latest Hospital Stay admission date
+4 ;adm date ivd, ien, dd ivd
NEW APCHINPB,APCHINPV,APCHINPD,APCHINPS,APCHVSIT,APCHM,APCHMEAS,APCHEVD,APCHM,APCHSX,APCHSMT,APCHSDFN
+5 ;get ien of latest H visit that is not contract health
SET APCHINPV=$$LASTHV(APCHSPAT)
+6 ;no hospital stays so don't bother
IF 'APCHINPV
QUIT
+7 ;admission date of last H visit
SET APCHINPB=$PIECE($PIECE(^AUPNVSIT(APCHINPV,0),U,1),".")
+8 SET APCHINPS=9999999-APCHINPB
+9 ;get discharge date
SET APCHINPD=$$DSCHDATE^APCLV(APCHINPV)
+10 ;if no discharge date, set to DT as this means the patient is in-house
IF APCHINPD=""
SET APCHINPD=DT
+11 XECUTE APCHSBRK
+12 ; <DISPLAY>
+13 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+14 ;loop through all visits from adm date to discharge date (or DT) and display measurements from
+15 ;H and I visits
+16 SET APCHSIVD=(9999999-APCHINPD-1)_".9999"
+17 FOR
SET APCHSIVD=$ORDER(^AUPNVSIT("AA",APCHSPAT,APCHSIVD))
IF $PIECE(APCHSIVD,".")>APCHINPS!(APCHSIVD="")
QUIT
Begin DoDot:1
+18 SET APCHVSIT=0
FOR
SET APCHVSIT=$ORDER(^AUPNVSIT("AA",APCHSPAT,APCHSIVD,APCHVSIT))
IF APCHVSIT'=+APCHVSIT
QUIT
Begin DoDot:2
+19 IF '$DATA(^AUPNVSIT(APCHVSIT,0))
QUIT
+20 ;only H and I
IF "HI"'[$PIECE(^AUPNVSIT(APCHVSIT,0),U,7)
QUIT
+21 SET APCHM=0
FOR
SET APCHM=$ORDER(^AUPNVMSR("AD",APCHVSIT,APCHM))
IF APCHM=""
QUIT
Begin DoDot:3
+22 ;GET EVENT DATE/TIME OR VISIT DATE/TIME
+23 IF '$DATA(^AUPNVMSR(APCHM,0))
QUIT
+24 IF $PIECE(^AUPNVMSR(APCHM,0),U,1)=""
QUIT
+25 ;entered in error so skip it
IF $PIECE($GET(^AUPNVMSR(APCHM,2)),U,1)
QUIT
+26 ;STRIP OFF SECONDS IF ENTERED PER SUSAN AND MARY ANN EMAIL
SET APCHEVD=+$EXTRACT($PIECE($GET(^AUPNVMSR(APCHM,12)),U,1),1,12)
+27 ;visit date/time if no event date time
IF APCHEVD=""!(APCHEVD=0)
SET APCHEVD=$PIECE(^AUPNVSIT(APCHINPV,0),U,1)
+28 IF APCHMDSP="D"
SET APCHMEAS(APCHEVD,$$VAL^XBDIQ1(9000010.01,APCHM,.01),APCHM)=""
+29 IF APCHMDSP="T"
SET APCHMEAS($$VAL^XBDIQ1(9000010.01,APCHM,.01),APCHEVD,APCHM)=""
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;now display them
+31 DO MEASDSP
+32 ; <CLEANUP>
MEASX KILL APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT,APCHMEAS
+1 QUIT
INPMEASD ;EP
+1 SET APCHMDSP="D"
+2 GOTO INPMEAS
INPMEAST ;EP
+1 SET APCHMDSP="T"
+2 GOTO INPMEAS
MEASDSP ;
+1 ;display by type
IF APCHMDSP="T"
GOTO MEASDSPT
+2 SET APCHSIVD=""
FOR
SET APCHSIVD=$ORDER(APCHMEAS(APCHSIVD),-1)
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,?2,$$DT(APCHSIVD)
+4 SET APCHMT=""
FOR
SET APCHMT=$ORDER(APCHMEAS(APCHSIVD,APCHMT))
IF APCHMT=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+5 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(APCHMEAS(APCHSIVD,APCHMT,APCHSDFN))
IF APCHSDFN=""!($DATA(APCHSQIT))
QUIT
DO MEASDSP1
End DoDot:2
End DoDot:1
+6 QUIT
MEASDSPT ;
+1 ;
+2 SET APCHMT=""
FOR
SET APCHMT=$ORDER(APCHMEAS(APCHMT))
IF APCHMT=""
QUIT
Begin DoDot:1
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 WRITE !?1,$SELECT(APCHMT="O2":"O2 Sat",1:APCHMT)
+5 SET APCHSIVD=""
FOR
SET APCHSIVD=$ORDER(APCHMEAS(APCHMT,APCHSIVD),-1)
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+6 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(APCHMEAS(APCHMT,APCHSIVD,APCHSDFN))
IF APCHSDFN=""!($DATA(APCHSQIT))
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 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+2 WRITE ?21,$SELECT(APCHMT="O2":"O2 Sat",1:APCHMT)
DO REST
+3 QUIT
MEASDSP2 ;
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+2 IF APCHSNPG
WRITE ?1,$SELECT(APCHMT="O2":"O2 Sat",1:APCHMT)
+3 WRITE ?9,$$DT(APCHSIVD)
+4 DO REST
+5 QUIT
REST ;
+1 WRITE ?29,$PIECE(^AUPNVMSR(APCHSDFN,0),U,4)
+2 IF $$VAL^XBDIQ1(9000010.01,APCHSDFN,.01)="O2"
Begin DoDot:1
+3 IF $PIECE(^AUPNVMSR(APCHSDFN,0),U,10)=""
QUIT
+4 WRITE ?41,"Supplemental O2: ",$PIECE(^AUPNVMSR(APCHSDFN,0),U,10),!
End DoDot:1
+5 ;no qualifiers
IF '$ORDER(^AUPNVMSR(APCHSDFN,5,0))
WRITE !
QUIT
+6 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVMSR(APCHSDFN,5,X))
IF X'=+X
QUIT
SET C=C+1
+7 WRITE ?41,"Qualifier"_$SELECT(C>1:"s",1:""),":"
+8 SET APCHSX=0
SET X=""
FOR
SET APCHSX=$ORDER(^AUPNVMSR(APCHSDFN,5,APCHSX))
IF APCHSX'=+APCHSX
QUIT
SET Y=$PIECE($GET(^AUPNVMSR(APCHSDFN,5,APCHSX,0)),U)
IF Y
SET X=X_$SELECT(X]"":", ",1:"")_$PIECE($GET(^GMRD(120.52,Y,0)),U,1)
+9 KILL APCHWP
+10 DO WP^APCHS82(X,23)
+11 SET APCHX=0
SET C=0
FOR
SET APCHX=$ORDER(APCHWP(APCHX))
IF APCHX'=+APCHX!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 SET C=C+1
+14 IF C>1
WRITE !
+15 WRITE ?53,APCHWP(APCHX)
End DoDot:1
+16 WRITE !
+17 QUIT
LASTHV(P) ;get last H visit that is not contract
+1 NEW X,Y,V
+2 SET V=""
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVSIT("AAH",P,X))
IF X'=+X!(V)
QUIT
Begin DoDot:1
+4 SET Y=0
FOR
SET Y=$ORDER(^AUPNVSIT("AAH",P,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+5 IF '$DATA(^AUPNVSIT(Y,0))
QUIT
+6 ;don't count contract visits
IF $PIECE(^AUPNVSIT(Y,0),U,3)="C"
QUIT
+7 SET V=Y
+8 QUIT
End DoDot:2
End DoDot:1
+9 QUIT V
