- 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
