APCHPWHR ; IHS/CMI/LAB - PCC HEALTH SUMMARY ;
;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
;
W:$D(IOF) @IOF
W !!,"This report will tally the number of Patient Wellness Handouts given to"
W !,"patients. The user will be able to tally based on handout type, location"
W !,"date the handout was generated and user/provider who generated the handout."
W !,"Optionally, the user can produce a list of patients receiving the handout."
W !!
S APCHJ=$J,APCHH=$H
GETDATES ;
BD ;get beginning date
W ! K DIR S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date of Patient Wellness Handout" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) D EXIT Q
S APCHBD=Y
ED ;get ending date
W ! S DIR(0)="DA^"_APCHBD_":DT:EP",DIR("A")="Enter ending date of Patient Wellness Handout: " S Y=APCHBD D DD^%DT S Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S APCHED=Y
S X1=APCHBD,X2=-1 D C^%DTC S APCHSD=X
;
TYPE ;
K APCHTYPE
W ! S DIR(0)="Y",DIR("A")="Do you wish to run the report for a particular patient handout",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G GETDATES
I 'Y G LOCT
TYPE1 ;
W ! S DIC="^APCHPWHT(",DIC("A")="Enter Patient Wellness Type: ",DIC(0)="AEMQ" D ^DIC
I Y=-1,'$D(APCHTYPE) W !,"No handout types selected." G TYPE
I Y=-1,$D(APCHTYPE) G LOCT
S APCHTYPE(+Y)=""
G TYPE1
LOCT ;
K APCHLOCT
W ! S DIR(0)="Y",DIR("A")="Do you wish to run the report for a particular location",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G TYPE
I Y=0 D G PROVT
.K APCHLOCT
LOCT1 ;
W ! S DIC="^AUTTLOC(",DIC("A")="Enter Location: ",DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1,'$D(APCHLOCT) W !,"No locations selected." G TYPE
I Y=-1,$D(APCHLOCT) G PROVT
S APCHLOCT(+Y)=""
G LOCT1
PROVT ;
;
K APCHPRVT
W ! S DIR(0)="Y",DIR("A")="Do you wish to run the report for a particular provider/user",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G LOCT
I 'Y D G LIST
.K APCHPRVT
PROVT1 ;
W ! S DIC="^VA(200,",DIC("A")="Enter Provider: ",DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1,'$D(APCHPRVT) W !,"No providers selected." G LOCT
I Y=-1,$D(APCHPRVT) G LIST
S APCHPRVT(+Y)=""
G PROVT1
;
LIST ;
S APCHLIST=""
W !! S DIR(0)="Y",DIR("A")="Do you want a list of patients",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
S APCHLIST=Y
I 'APCHLIST S APCHSORT="" G ZIS
SORT ;
S APCHSORT=""
S DIR(0)="S^N:Name of Patient;P:Provider/User;L:Location;T:Type of Handout;D:Date Handout Generated",DIR("A")="How do you want the list sorted"
S DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
S APCHSORT=Y
;
ZIS ;EP
D DEMOCHK^APCLUTL(.APCHDEMO)
I APCHDEMO=-1 G LIST
W !! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) D EXIT Q
S APCHOPT=Y
I Y="B" D BROWSE,EXIT Q
S XBRP="PRINT^APCHPWHR",XBRC="EN^APCHPWHR",XBRX="EXIT^APCHPWHR",XBNS="APCH;DFN"
D ^XBDBQUE
D EXIT1
Q
;
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^APCHPWHR"")"
S XBRC="EN^APCHPWHR",XBRX="EXIT^APCHPWHR",XBIOP=0 D ^XBDBQUE
Q
EXIT ;
;K ^XTMP("APCHPWHR",APCHJ,APCHH)
D EN^XBVK("APCH")
K DFN
D ^XBFMK
Q
;
EXIT1 ;
D CLEAR^VALM1
D FULL^VALM1
D EN^XBVK("APCH")
K DFN
D ^XBFMK
Q
;
PRINT ;
S APCHPG=0
K APCHQUIT
I APCHLIST I '$D(^XTMP("APCHPWHR",APCHJ,APCHH)) D HEADER W !!,"No data to report.",! Q
I APCHPWHC=0 D HDR W !!,"No data to report.",! Q
;print tally then print list
D HDR
S APCHX=0 F S APCHX=$O(APCHPWHT(APCHX)) Q:APCHX'=+APCHX D
.I $Y>(IOSL-3) D HDR Q:$D(APCHQUIT)
.W APCHPWHT(APCHX,0),!
.Q
Q:$D(APCHQUIT)
;first reorder by sort item
S APCHIEN=0 F S APCHIEN=$O(^XTMP("APCHPWHR",APCHJ,APCHH,APCHIEN)) Q:APCHIEN'=+APCHIEN D
.D
..S V=""
..I APCHSORT="T" S V=$$VAL^XBDIQ1(9001027,APCHIEN,.02) Q
..I APCHSORT="D" S V=$$VALI^XBDIQ1(9001027,APCHIEN,.04) Q
..I APCHSORT="N" S V=$$VAL^XBDIQ1(9001027,APCHIEN,.01) Q
..I APCHSORT="L" S V=$$VAL^XBDIQ1(9001027,APCHIEN,.06) Q
..I APCHSORT="P" S V=$$VAL^XBDIQ1(9001027,APCHIEN,.03) Q
.I V="" S V="UNKNOWN"
.S ^XTMP("APCHPWHR",APCHJ,APCHH,"SORT",V,APCHIEN)=""
I 'APCHLIST G N
D HEADER
S APCHSV="" F S APCHSV=$O(^XTMP("APCHPWHR",APCHJ,APCHH,"SORT",APCHSV)) Q:APCHSV=""!($D(APCHQUIT)) D
.S APCHIEN=0 F S APCHIEN=$O(^XTMP("APCHPWHR",APCHJ,APCHH,"SORT",APCHSV,APCHIEN)) Q:APCHIEN=""!($D(APCHQUIT)) D
..I $Y>(IOSL-3) D HEADER I $D(APCHQUIT) Q
..W !,$$HRN^AUPNPAT($$VALI^XBDIQ1(9001027,APCHIEN,.01),DUZ(2)),?8,$E($$VAL^XBDIQ1(9001027,APCHIEN,.01),1,20)
..W ?30,$$DATE^APCHSMU($$VALI^XBDIQ1(9001027,APCHIEN,.04)),?39,$E($$VAL^XBDIQ1(9001027,APCHIEN,.02),1,20)
..W ?60,$E($$VAL^XBDIQ1(9001027,APCHIEN,.03),1,14),?75,$$VAL^XBDIQ1(9999999.06,+$$VALI^XBDIQ1(9001027,APCHIEN,.06),.08)
..Q
.Q
N ;
W !!
Q
G:APCHPG=0 HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
S APCHPG=APCHPG+1
W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********",!
W !,"Patient Wellness Handout",?45,"Report Date: ",$$FMTE^XLFDT(DT),?72,"Page: ",APCHPG,!,$TR($J("",(IOM-2))," ","-"),!
W !,"HRN",?8,"Patient Name",?30,"Date",?39,"Type",?60,"Provider",?75,"Loc"
W !,$$REPEAT^XLFSTR("-",79),!
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")
;----------
;
EN ;
S APCHCNT=0,APCHPWHC=0
K APCHT,APCHPWHT
K ^XTMP("APCHPWHR",APCHJ,APCHH)
S ^XTMP("APCHPWHR",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^APCH PWH REPORT"
NEW X,Y,APCHN,L,P,T
;
F S APCHSD=$O(^APCHPWHL("AC",APCHSD)) Q:APCHSD'=+APCHSD!(APCHSD>APCHED) D
.S APCHIEN=0 F S APCHIEN=$O(^APCHPWHL("AC",APCHSD,APCHIEN)) Q:APCHIEN'=+APCHIEN D
..S APCHN=^APCHPWHL(APCHIEN,0)
..S P=$P(^APCHPWHL(APCHIEN,0),U,1)
..Q:$$DEMO^APCLUTL(P,APCHDEMO)
..Q:'$P(APCHN,U,2)
..I $D(APCHTYPE) Q:'$D(APCHTYPE($P(APCHN,U,2)))
..I $D(APCHLOCT) Q:'$P(APCHN,U,6) Q:'$D(APCHLOCT($P(APCHN,U,6)))
..I $D(APCHPRVT) Q:'$P(APCHN,U,3) Q:'$D(APCHPRVT($P(APCHN,U,3)))
..S APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06))=$G(APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06)))+1
..S APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06),$$VAL^XBDIQ1(9001027,APCHIEN,.02))=$G(APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06),$$VAL^XBDIQ1(9001027,APCHIEN,.02)))+1
..S APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06),$$VAL^XBDIQ1(9001027,APCHIEN,.02),$$VAL^XBDIQ1(9001027,APCHIEN,.03))=$G(APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06),$$VAL^XBDIQ1(9001027,APCHIEN,.02),$$VAL^XBDIQ1(9001027,APCHIEN,.03)))+1
..S ^XTMP("APCHPWHR",APCHJ,APCHH,APCHIEN)="",APCHPWHC=APCHPWHC+1
;S X="LOCATION",$E(X,55)="#" D S(X)
S L="" F S L=$O(APCHT(L)) Q:L="" D
.D S(" ")
.S Y=L,$E(Y,55)=$J(APCHT(L),6) D S(Y)
.S T="" F S T=$O(APCHT(L,T)) Q:T="" D
..D S(" ") S Y="",$E(Y,3)=T,$E(Y,55)=$J(APCHT(L,T),6) D S(Y)
..D S(" ") S P="" F S P=$O(APCHT(L,T,P)) Q:P="" D
...S Y="",$E(Y,6)=P,$E(Y,55)=$J(APCHT(L,T,P),6) D S(Y)
Q
S(T) ;
S APCHCNT=APCHCNT+1
S APCHPWHT(APCHCNT,0)=T
Q
HDR ;
G:APCHPG=0 HDR1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT="" Q
HDR1 ;
W:$D(IOF) @IOF
S APCHPG=APCHPG+1
W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********",!
W $$CTR("PATIENT WELLNESS HANDOUT TALLY",80),!
W $$CTR("Date Range: "_$$FMTE^XLFDT(APCHBD)_" - "_$$FMTE^XLFDT(APCHED)),!
S X=0,Y="" F S X=$O(APCHTYPE(X)) Q:X'=+X S:Y]"" Y=Y_"; " S Y=Y_$P(^APCHPWHT(X,0),U)
W "Handout Types Selected: "_$S('$D(APCHTYPE):"All",1:""),Y,!
S Y="" S X=0 F S X=$O(APCHLOCT(X)) Q:X'=+X S:Y]"" Y=Y_"; " S Y=Y_$E($P(^DIC(4,X,0),U),1,18)
W "Locations Selected: "_$S('$D(APCHLOCT):"All",1:""),Y,!
S Y="",X=0 F S X=$O(APCHPRVT(X)) Q:X'=+X S:Y]"" Y=Y_"; " S Y=Y_$E($P(^VA(200,X,0),U),1,18)
W "Providers/Users Selected: "_$S('$D(APCHPRVT):"All",1:""),Y,!
W "--------------------------------------------------------------------",!
W "LOCATION",?55,"#",!
W "--------------------------------------------------------------------",!
Q
;
HELP ;EP -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
LMEXIT ; -- exit code
K APCHPWHT,APCHT
D CLEAR^VALM1
D FULL^VALM1
Q
;
EXPND ; -- expand code
Q
APCHPWHR ; IHS/CMI/LAB - PCC HEALTH SUMMARY ;
+1 ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
+2 ;
+3 IF $DATA(IOF)
WRITE @IOF
+4 WRITE !!,"This report will tally the number of Patient Wellness Handouts given to"
+5 WRITE !,"patients. The user will be able to tally based on handout type, location"
+6 WRITE !,"date the handout was generated and user/provider who generated the handout."
+7 WRITE !,"Optionally, the user can produce a list of patients receiving the handout."
+8 WRITE !!
+9 SET APCHJ=$JOB
SET APCHH=$HOROLOG
GETDATES ;
BD ;get beginning date
+1 WRITE !
KILL DIR
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter beginning Date of Patient Wellness Handout"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
DO EXIT
QUIT
+3 SET APCHBD=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="DA^"_APCHBD_":DT:EP"
SET DIR("A")="Enter ending date of Patient Wellness Handout: "
SET Y=APCHBD
DO DD^%DT
SET Y=""
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET APCHED=Y
+4 SET X1=APCHBD
SET X2=-1
DO C^%DTC
SET APCHSD=X
+5 ;
TYPE ;
+1 KILL APCHTYPE
+2 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Do you wish to run the report for a particular patient handout"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO GETDATES
+4 IF 'Y
GOTO LOCT
TYPE1 ;
+1 WRITE !
SET DIC="^APCHPWHT("
SET DIC("A")="Enter Patient Wellness Type: "
SET DIC(0)="AEMQ"
DO ^DIC
+2 IF Y=-1
IF '$DATA(APCHTYPE)
WRITE !,"No handout types selected."
GOTO TYPE
+3 IF Y=-1
IF $DATA(APCHTYPE)
GOTO LOCT
+4 SET APCHTYPE(+Y)=""
+5 GOTO TYPE1
LOCT ;
+1 KILL APCHLOCT
+2 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Do you wish to run the report for a particular location"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO TYPE
+4 IF Y=0
Begin DoDot:1
+5 KILL APCHLOCT
End DoDot:1
GOTO PROVT
LOCT1 ;
+1 WRITE !
SET DIC="^AUTTLOC("
SET DIC("A")="Enter Location: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+2 IF Y=-1
IF '$DATA(APCHLOCT)
WRITE !,"No locations selected."
GOTO TYPE
+3 IF Y=-1
IF $DATA(APCHLOCT)
GOTO PROVT
+4 SET APCHLOCT(+Y)=""
+5 GOTO LOCT1
PROVT ;
+1 ;
+2 KILL APCHPRVT
+3 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Do you wish to run the report for a particular provider/user"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO LOCT
+5 IF 'Y
Begin DoDot:1
+6 KILL APCHPRVT
End DoDot:1
GOTO LIST
PROVT1 ;
+1 WRITE !
SET DIC="^VA(200,"
SET DIC("A")="Enter Provider: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+2 IF Y=-1
IF '$DATA(APCHPRVT)
WRITE !,"No providers selected."
GOTO LOCT
+3 IF Y=-1
IF $DATA(APCHPRVT)
GOTO LIST
+4 SET APCHPRVT(+Y)=""
+5 GOTO PROVT1
+6 ;
LIST ;
+1 SET APCHLIST=""
+2 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Do you want a list of patients"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
DO EXIT
QUIT
+4 SET APCHLIST=Y
+5 IF 'APCHLIST
SET APCHSORT=""
GOTO ZIS
SORT ;
+1 SET APCHSORT=""
+2 SET DIR(0)="S^N:Name of Patient;P:Provider/User;L:Location;T:Type of Handout;D:Date Handout Generated"
SET DIR("A")="How do you want the list sorted"
+3 SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
DO EXIT
QUIT
+5 SET APCHSORT=Y
+6 ;
ZIS ;EP
+1 DO DEMOCHK^APCLUTL(.APCHDEMO)
+2 IF APCHDEMO=-1
GOTO LIST
+3 WRITE !!
SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
DO EXIT
QUIT
+5 SET APCHOPT=Y
+6 IF Y="B"
DO BROWSE
DO EXIT
QUIT
+7 SET XBRP="PRINT^APCHPWHR"
SET XBRC="EN^APCHPWHR"
SET XBRX="EXIT^APCHPWHR"
SET XBNS="APCH;DFN"
+8 DO ^XBDBQUE
+9 DO EXIT1
+10 QUIT
+11 ;
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^APCHPWHR"")"
+2 SET XBRC="EN^APCHPWHR"
SET XBRX="EXIT^APCHPWHR"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
EXIT ;
+1 ;K ^XTMP("APCHPWHR",APCHJ,APCHH)
+2 DO EN^XBVK("APCH")
+3 KILL DFN
+4 DO ^XBFMK
+5 QUIT
+6 ;
EXIT1 ;
+1 DO CLEAR^VALM1
+2 DO FULL^VALM1
+3 DO EN^XBVK("APCH")
+4 KILL DFN
+5 DO ^XBFMK
+6 QUIT
+7 ;
PRINT ;
+1 SET APCHPG=0
+2 KILL APCHQUIT
+3 IF APCHLIST
IF '$DATA(^XTMP("APCHPWHR",APCHJ,APCHH))
DO HEADER
WRITE !!,"No data to report.",!
QUIT
+4 IF APCHPWHC=0
DO HDR
WRITE !!,"No data to report.",!
QUIT
+5 ;print tally then print list
+6 DO HDR
+7 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHPWHT(APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-3)
DO HDR
IF $DATA(APCHQUIT)
QUIT
+9 WRITE APCHPWHT(APCHX,0),!
+10 QUIT
End DoDot:1
+11 IF $DATA(APCHQUIT)
QUIT
+12 ;first reorder by sort item
+13 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(^XTMP("APCHPWHR",APCHJ,APCHH,APCHIEN))
IF APCHIEN'=+APCHIEN
QUIT
Begin DoDot:1
+14 Begin DoDot:2
+15 SET V=""
+16 IF APCHSORT="T"
SET V=$$VAL^XBDIQ1(9001027,APCHIEN,.02)
QUIT
+17 IF APCHSORT="D"
SET V=$$VALI^XBDIQ1(9001027,APCHIEN,.04)
QUIT
+18 IF APCHSORT="N"
SET V=$$VAL^XBDIQ1(9001027,APCHIEN,.01)
QUIT
+19 IF APCHSORT="L"
SET V=$$VAL^XBDIQ1(9001027,APCHIEN,.06)
QUIT
+20 IF APCHSORT="P"
SET V=$$VAL^XBDIQ1(9001027,APCHIEN,.03)
QUIT
End DoDot:2
+21 IF V=""
SET V="UNKNOWN"
+22 SET ^XTMP("APCHPWHR",APCHJ,APCHH,"SORT",V,APCHIEN)=""
End DoDot:1
+23 IF 'APCHLIST
GOTO N
+24 DO HEADER
+25 SET APCHSV=""
FOR
SET APCHSV=$ORDER(^XTMP("APCHPWHR",APCHJ,APCHH,"SORT",APCHSV))
IF APCHSV=""!($DATA(APCHQUIT))
QUIT
Begin DoDot:1
+26 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(^XTMP("APCHPWHR",APCHJ,APCHH,"SORT",APCHSV,APCHIEN))
IF APCHIEN=""!($DATA(APCHQUIT))
QUIT
Begin DoDot:2
+27 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(APCHQUIT)
QUIT
+28 WRITE !,$$HRN^AUPNPAT($$VALI^XBDIQ1(9001027,APCHIEN,.01),DUZ(2)),?8,$EXTRACT($$VAL^XBDIQ1(9001027,APCHIEN,.01),1,20)
+29 WRITE ?30,$$DATE^APCHSMU($$VALI^XBDIQ1(9001027,APCHIEN,.04)),?39,$EXTRACT($$VAL^XBDIQ1(9001027,APCHIEN,.02),1,20)
+30 WRITE ?60,$EXTRACT($$VAL^XBDIQ1(9001027,APCHIEN,.03),1,14),?75,$$VAL^XBDIQ1(9999999.06,+$$VALI^XBDIQ1(9001027,APCHIEN,.06),.08)
+31 QUIT
End DoDot:2
+32 QUIT
End DoDot:1
N ;
+1 WRITE !!
+2 QUIT
+1 IF APCHPG=0
GOTO HEAD1
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCHQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 SET APCHPG=APCHPG+1
+3 WRITE !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********",!
+4 WRITE !,"Patient Wellness Handout",?45,"Report Date: ",$$FMTE^XLFDT(DT),?72,"Page: ",APCHPG,!,$TRANSLATE($JUSTIFY("",(IOM-2))," ","-"),!
+5 WRITE !,"HRN",?8,"Patient Name",?30,"Date",?39,"Type",?60,"Provider",?75,"Loc"
+6 WRITE !,$$REPEAT^XLFSTR("-",79),!
+7 QUIT
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 ;
EN ;
+1 SET APCHCNT=0
SET APCHPWHC=0
+2 KILL APCHT,APCHPWHT
+3 KILL ^XTMP("APCHPWHR",APCHJ,APCHH)
+4 SET ^XTMP("APCHPWHR",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^APCH PWH REPORT"
+5 NEW X,Y,APCHN,L,P,T
+6 ;
+7 FOR
SET APCHSD=$ORDER(^APCHPWHL("AC",APCHSD))
IF APCHSD'=+APCHSD!(APCHSD>APCHED)
QUIT
Begin DoDot:1
+8 SET APCHIEN=0
FOR
SET APCHIEN=$ORDER(^APCHPWHL("AC",APCHSD,APCHIEN))
IF APCHIEN'=+APCHIEN
QUIT
Begin DoDot:2
+9 SET APCHN=^APCHPWHL(APCHIEN,0)
+10 SET P=$PIECE(^APCHPWHL(APCHIEN,0),U,1)
+11 IF $$DEMO^APCLUTL(P,APCHDEMO)
QUIT
+12 IF '$PIECE(APCHN,U,2)
QUIT
+13 IF $DATA(APCHTYPE)
IF '$DATA(APCHTYPE($PIECE(APCHN,U,2)))
QUIT
+14 IF $DATA(APCHLOCT)
IF '$PIECE(APCHN,U,6)
QUIT
IF '$DATA(APCHLOCT($PIECE(APCHN,U,6)))
QUIT
+15 IF $DATA(APCHPRVT)
IF '$PIECE(APCHN,U,3)
QUIT
IF '$DATA(APCHPRVT($PIECE(APCHN,U,3)))
QUIT
+16 SET APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06))=$GET(APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06)))+1
+17 SET APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06),$$VAL^XBDIQ1(9001027,APCHIEN,.02))=$GET(APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06),$$VAL^XBDIQ1(9001027,APCHIEN,.02)))+1
+18 SET APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06),$$VAL^XBDIQ1(9001027,APCHIEN,.02),$$VAL^XBDIQ1(9001027,APCHIEN,.03))=$GET(APCHT($$VAL^XBDIQ1(9001027,APCHIEN,.06),$$VAL^XBDIQ1(9001027,APCHIEN,.02),$$VAL^XBDIQ1(9001027,APCHIEN,.03)))+
1
+19 SET ^XTMP("APCHPWHR",APCHJ,APCHH,APCHIEN)=""
SET APCHPWHC=APCHPWHC+1
End DoDot:2
End DoDot:1
+20 ;S X="LOCATION",$E(X,55)="#" D S(X)
+21 SET L=""
FOR
SET L=$ORDER(APCHT(L))
IF L=""
QUIT
Begin DoDot:1
+22 DO S(" ")
+23 SET Y=L
SET $EXTRACT(Y,55)=$JUSTIFY(APCHT(L),6)
DO S(Y)
+24 SET T=""
FOR
SET T=$ORDER(APCHT(L,T))
IF T=""
QUIT
Begin DoDot:2
+25 DO S(" ")
SET Y=""
SET $EXTRACT(Y,3)=T
SET $EXTRACT(Y,55)=$JUSTIFY(APCHT(L,T),6)
DO S(Y)
+26 DO S(" ")
SET P=""
FOR
SET P=$ORDER(APCHT(L,T,P))
IF P=""
QUIT
Begin DoDot:3
+27 SET Y=""
SET $EXTRACT(Y,6)=P
SET $EXTRACT(Y,55)=$JUSTIFY(APCHT(L,T,P),6)
DO S(Y)
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
S(T) ;
+1 SET APCHCNT=APCHCNT+1
+2 SET APCHPWHT(APCHCNT,0)=T
+3 QUIT
HDR ;
+1 IF APCHPG=0
GOTO HDR1
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCHQUIT=""
QUIT
HDR1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 SET APCHPG=APCHPG+1
+3 WRITE !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********",!
+4 WRITE $$CTR("PATIENT WELLNESS HANDOUT TALLY",80),!
+5 WRITE $$CTR("Date Range: "_$$FMTE^XLFDT(APCHBD)_" - "_$$FMTE^XLFDT(APCHED)),!
+6 SET X=0
SET Y=""
FOR
SET X=$ORDER(APCHTYPE(X))
IF X'=+X
QUIT
IF Y]""
SET Y=Y_"; "
SET Y=Y_$PIECE(^APCHPWHT(X,0),U)
+7 WRITE "Handout Types Selected: "_$SELECT('$DATA(APCHTYPE):"All",1:""),Y,!
+8 SET Y=""
SET X=0
FOR
SET X=$ORDER(APCHLOCT(X))
IF X'=+X
QUIT
IF Y]""
SET Y=Y_"; "
SET Y=Y_$EXTRACT($PIECE(^DIC(4,X,0),U),1,18)
+9 WRITE "Locations Selected: "_$SELECT('$DATA(APCHLOCT):"All",1:""),Y,!
+10 SET Y=""
SET X=0
FOR
SET X=$ORDER(APCHPRVT(X))
IF X'=+X
QUIT
IF Y]""
SET Y=Y_"; "
SET Y=Y_$EXTRACT($PIECE(^VA(200,X,0),U),1,18)
+11 WRITE "Providers/Users Selected: "_$SELECT('$DATA(APCHPRVT):"All",1:""),Y,!
+12 WRITE "--------------------------------------------------------------------",!
+13 WRITE "LOCATION",?55,"#",!
+14 WRITE "--------------------------------------------------------------------",!
+15 QUIT
+16 ;
HELP ;EP -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
LMEXIT ; -- exit code
+1 KILL APCHPWHT,APCHT
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 QUIT
+5 ;
EXPND ; -- expand code
+1 QUIT
