APCHPWHU ; IHS/CMI/LAB - PCC HEALTH SUMMARY ;
;;2.0;IHS PCC SUITE;**6,7,11**;MAY 14, 2009;Build 58
;
SUBHEAD ;EP - print subheader
NEW X
S X=$TR($J("",(IOM-10))," ","_")
D S^APCHPWH1(X,1)
;S X=$S($P(^APCHPWHC(APCHSCMP,0),U,4)]"":$P(^APCHPWHC(APCHSCMP,0),U,4),1:$P(^APCHPWHC(APCHSCMP,0),U))_" - "
;D S^APCHPWH1(X)
Q
WRITET(TEXT) ;EP
NEW X,Y
S X=$O(^APCHPWHI("B",TEXT,0))
I X="" Q
S Y=0 F S Y=$O(^APCHPWHI(X,11,Y)) Q:Y'=+Y D S^APCHPWH1(^APCHPWHI(X,11,Y,0))
Q
WRITEF(FORM,TEXT) ;EP
NEW X,Y
S X=$O(^APCHPWHF(FORM,11,"B",TEXT,0))
I X="" Q
S Y=0 F S Y=$O(^APCHPWHF(FORM,11,X,11,Y)) Q:Y'=+Y D S^APCHPWH1(^APCHPWHF(FORM,11,X,11,Y,0))
Q
EHR(DFN,APCHPWHT) ;*16* CMI/GRL support for EHR
D EN^XBNEW("PRINT^APCHPWHG","DFN;APCHSTYP")
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
;
UPDLOG(P,T,D) ;EP - update pwh log
I $G(P)="" Q
I $G(T)="" Q
NEW DIC,X,DD,DO,D0
S X=P,DIC="^APCHPWHL(",DIC(0)="L",DIADD=1,DLAYGO=9001027
S DIC("DR")=".02////"_T_";.03////"_D_";.04////"_DT_";.05///"_$$NOW^XLFDT_";.06////"_DUZ(2)
K DD,D0,D0
D FILE^DICN
Q
;
UPDDEF ;EP - called from option to update default PWH for the site
W !!,"This option is used to set the default Patient Wellness Handout"
W !,"for a site."
W !!
K DIC S DIC="^APCCCTRL(",DIC("B")=$P(^DIC(4,DUZ(2),0),U),DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1 Q
S DA=+Y,DIE="^APCCCTRL(",DR=".16" D ^DIE
D ^XBFMK
Q
;
CPT(P,BDATE,EDATE,T,F,SCEX) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
S SCEX=$G(SCEX)
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..I SCEX]"",SCEX[$P(^AUPNVSIT(V,0),U,7) Q
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXAPI($P(^AUPNVCPT(X,0),U),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)
I F=6 S V=$P(^AUPNVCPT(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U)),U,2)_"^"_G
Q ""
;
RAD(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V,C
S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVRAD("AD",V))
..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G) D
...S C=$P(^AUPNVRAD(X,0),U) Q:C="" S C=$P($G(^RAMIS(71,C,0)),U,9) Q:C=""
...I $$ICD^ATXAPI(C,T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^RAMIS(71,$P(^AUPNVRAD(G,0),U),0),U,9)
I F=6 S V=$P(^AUPNVRAD(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^RAMIS(71,$P(^AUPNVRAD(G,0),U),0),U)_"^"_G
Q ""
;
TRAN(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT IN A TRAN CODE
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVTC("AD",V))
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXAPI($P(^AUPNVTC(X,0),U,7),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVTC(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVTC(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVTC(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVTC(G,0),U,7)),U,2)
I F=6 S V=$P(^AUPNVTC(G,0),U,3) I V Q 1_"^"_$P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVTC(G,0),U,7)),U,2)_"^"_G
Q ""
;
APCHPWHU ; IHS/CMI/LAB - PCC HEALTH SUMMARY ;
+1 ;;2.0;IHS PCC SUITE;**6,7,11**;MAY 14, 2009;Build 58
+2 ;
SUBHEAD ;EP - print subheader
+1 NEW X
+2 SET X=$TRANSLATE($JUSTIFY("",(IOM-10))," ","_")
+3 DO S^APCHPWH1(X,1)
+4 ;S X=$S($P(^APCHPWHC(APCHSCMP,0),U,4)]"":$P(^APCHPWHC(APCHSCMP,0),U,4),1:$P(^APCHPWHC(APCHSCMP,0),U))_" - "
+5 ;D S^APCHPWH1(X)
+6 QUIT
WRITET(TEXT) ;EP
+1 NEW X,Y
+2 SET X=$ORDER(^APCHPWHI("B",TEXT,0))
+3 IF X=""
QUIT
+4 SET Y=0
FOR
SET Y=$ORDER(^APCHPWHI(X,11,Y))
IF Y'=+Y
QUIT
DO S^APCHPWH1(^APCHPWHI(X,11,Y,0))
+5 QUIT
WRITEF(FORM,TEXT) ;EP
+1 NEW X,Y
+2 SET X=$ORDER(^APCHPWHF(FORM,11,"B",TEXT,0))
+3 IF X=""
QUIT
+4 SET Y=0
FOR
SET Y=$ORDER(^APCHPWHF(FORM,11,X,11,Y))
IF Y'=+Y
QUIT
DO S^APCHPWH1(^APCHPWHF(FORM,11,X,11,Y,0))
+5 QUIT
EHR(DFN,APCHPWHT) ;*16* CMI/GRL support for EHR
+1 DO EN^XBNEW("PRINT^APCHPWHG","DFN;APCHSTYP")
+2 QUIT
+3 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
+3 ;
UPDLOG(P,T,D) ;EP - update pwh log
+1 IF $GET(P)=""
QUIT
+2 IF $GET(T)=""
QUIT
+3 NEW DIC,X,DD,DO,D0
+4 SET X=P
SET DIC="^APCHPWHL("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9001027
+5 SET DIC("DR")=".02////"_T_";.03////"_D_";.04////"_DT_";.05///"_$$NOW^XLFDT_";.06////"_DUZ(2)
+6 KILL DD,D0,D0
+7 DO FILE^DICN
+8 QUIT
+9 ;
UPDDEF ;EP - called from option to update default PWH for the site
+1 WRITE !!,"This option is used to set the default Patient Wellness Handout"
+2 WRITE !,"for a site."
+3 WRITE !!
+4 KILL DIC
SET DIC="^APCCCTRL("
SET DIC("B")=$PIECE(^DIC(4,DUZ(2),0),U)
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+5 IF Y=-1
QUIT
+6 SET DA=+Y
SET DIE="^APCCCTRL("
SET DR=".16"
DO ^DIE
+7 DO ^XBFMK
+8 QUIT
+9 ;
CPT(P,BDATE,EDATE,T,F,SCEX) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 SET SCEX=$GET(SCEX)
+5 IF $GET(EDATE)=""
QUIT ""
+6 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+7 ;go through visits in a date range for this patient, check cpts
+8 NEW D,BD,ED,X,Y,D,G,V
+9 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+10 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+11 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+14 IF SCEX]""
IF SCEX[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+16 IF $$ICD^ATXAPI($PIECE(^AUPNVCPT(X,0),U),T,1)
SET G=X
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF 'G
QUIT ""
+21 IF F=1
QUIT $SELECT(G:1,1:"")
+22 IF F=2
QUIT G
+23 IF F=3
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+24 IF F=4
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+25 IF F=5
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U)),U,2)
+26 IF F=6
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U)),U,2)_"^"_G
+27 QUIT ""
+28 ;
RAD(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V,C
+8 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVRAD("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVRAD("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 SET C=$PIECE(^AUPNVRAD(X,0),U)
IF C=""
QUIT
SET C=$PIECE($GET(^RAMIS(71,C,0)),U,9)
IF C=""
QUIT
+15 IF $$ICD^ATXAPI(C,T,1)
SET G=X
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 IF 'G
QUIT ""
+20 IF F=1
QUIT $SELECT(G:1,1:"")
+21 IF F=2
QUIT G
+22 IF F=3
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+23 IF F=4
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+24 IF F=5
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE(^RAMIS(71,$PIECE(^AUPNVRAD(G,0),U),0),U,9)
+25 IF F=6
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE(^RAMIS(71,$PIECE(^AUPNVRAD(G,0),U),0),U)_"^"_G
+26 QUIT ""
+27 ;
TRAN(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT IN A TRAN CODE
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVTC("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF $$ICD^ATXAPI($PIECE(^AUPNVTC(X,0),U,7),T,1)
SET G=X
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF 'G
QUIT ""
+19 IF F=1
QUIT $SELECT(G:1,1:"")
+20 IF F=2
QUIT G
+21 IF F=3
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+22 IF F=4
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+23 IF F=5
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVTC(G,0),U,7)),U,2)
+24 IF F=6
SET V=$PIECE(^AUPNVTC(G,0),U,3)
IF V
QUIT 1_"^"_$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVTC(G,0),U,7)),U,2)_"^"_G
+25 QUIT ""
+26 ;
