APCLDE4P ; IHS/CMI/LAB - list refusals ;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;
;
PRINT ;EP - called from xbdbque
D PRINT1
D DONE
Q
PRINT1 ;
S APCLPG=0 K APCLQUIT
K APCLLSTP S APCLTALP=0
I '$D(^XTMP("APCLDE4",APCLJ,APCLH)) D HEADER W !!,"No data to report.",! G DONE
D HEADER
S APCLPTOT=$$PTOT
W !," Total Number of Patients in TEMPLATE:",?40,$J($$COM(APCLPTOT,0),8)
S APCLTOT=$$TOT
W !!," Total Number of Patients screened",?40,$J($$COM(APCLTOT,0),8),?55,$$PER(APCLTOT,APCLPTOT)
S APCLTALP=1
W !!?46,"#",?53,"% of patients",$S(APCLTALP:" screened",1:"")
D RES
Q:$$END
D GENDER
Q:$$END
D AGE
Q:$$END
D PRVSC
Q:$$END
D PRVV
Q:$$END
D DESPRV
Q:$$END
D CLINIC
Q:$$END
D DATE
Q:$$END
D MH
Q:$$END
D SS
Q:$$END
D CD
Q:$$END
K ^TMP($J)
I APCLLIST D LIST
Q
RES ;
Q:'$D(APCLTALL(1))
;TALLY BY RESULT FIRST
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,2) S R=$P(R,";")_" "_$P(R,";",2) S:R="" R="NO RESULT RECORDED" S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Result",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
GENDER ;
Q:'$D(APCLTALL(2))
;TALLY BY GENDER OF PATIENT
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,3) S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Gender",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
.Q
Q
AGE ;
Q:'$D(APCLTALL(3))
;TALLY BY age OF PATIENT
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,4) S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Age",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX_" yrs"),Y=38-Y W !?Y,APCLX," yrs",?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
PRVSC ;
Q:'$D(APCLTALL(4))
;TALLY BY PRIMARY provider OF service
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,5) S:R="" R="UNKNOWN" S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Provider who screened",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
PRVV ;
Q:'$D(APCLTALL(7))
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,7) S:R="" R="UNKNOWN" S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Primary Provider of Visit",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
DESPRV ;
Q:'$D(APCLTALL(11))
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,11) S:R="" R="UNKNOWN" S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Designated Primary Care Provider",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
MH ;
Q:'$D(APCLTALL(8))
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,8) S:R="" R="UNKNOWN" S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Designated Mental Health Provider",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
SS ;
Q:'$D(APCLTALL(9))
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,9) S:R="" R="UNKNOWN" S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Designated Social Services Provider",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
CD ;
Q:'$D(APCLTALL(10))
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,10) S:R="" R="UNKNOWN" S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Designated A/SA Provider",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
CLINIC ;
Q:'$D(APCLTALL(5))
;TALLY BY clinic
K APCLRES S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,6) S:R="" R="UNKNOWN" S APCLRES(R)=$G(APCLRES(R))+1
W !
W !," By Clinic",!
S APCLX="" F S APCLX=$O(APCLRES(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L(APCLX),Y=38-Y W !?Y,APCLX,?40,$J($$COM($G(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT) K APCLRES(APCLX)
Q
DATE ;
Q:'$D(APCLTALL(6))
;TALLY BY date OF service
K ^TMP($J) S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X D
.S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X) ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
.S R=$P(APCLY,U,1) S ^TMP($J,R)=$G(^TMP($J,R))+1
W !
W !," By Date",!
S APCLX="" F S APCLX=$O(^TMP($J,APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
.Q:$$END
.S Y=$L($$FMTE^XLFDT(APCLX)),Y=38-Y W !?Y,$$FMTE^XLFDT(APCLX),?40,$J($$COM($G(^TMP($J,APCLX)),0),8),?55,$$PER(^TMP($J,APCLX),APCLTOT) K ^TMP($J,APCLX)
Q
;
PER(N,D) ;return % of n/d
I 'D Q "0%"
NEW Z
S Z=N/D,Z=Z*100,Z=$J(Z,5,1)
Q $$STRIP^XLFSTR(Z," ")_"%"
COM(X,X2,X3) ;
D COMMA^%DTC
Q $$STRIP^XLFSTR(X," ")
END() ;
I $Y<(IOSL-3) Q 0
D HEADER
I $D(APCLQUIT) Q 1
Q 0
ENDL() ;
I $Y<(IOSL-8) Q 0
D HEADER
I $D(APCLQUIT) Q 1
Q 0
TOT() ;
NEW C,X
S C=0
S X=0 F S X=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)) Q:X'=+X S C=C+1
Q C
PTOT() ;
NEW C,X
S C=0
S X=0 F S X=$O(^DIBT(APCLSEAT,1,X)) Q:X'=+X S C=C+1
Q C
G:'APCLPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
W !,$$CTR("*** DEPRESSION SCREENING PATIENT TALLY"_$S(APCLLIST:" AND PATIENT LISTING",1:"")_" ***",80),!
S X="Screening Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80),!
I APCLEXPC S X="This report includes data from the BH Clinics" W $$CTR(X,80),!
I 'APCLEXPC S X="This report excludes data from the BH Clinics" W $$CTR(X,80),!
S X="SEARCH TEMPLATE OF PATIENTS: "_$P(^DIBT(APCLSEAT,0),U) W $$CTR(X,80),!
I $G(APCLLSTP),APCLSCRD S X="Listing of those patients screened" W $$CTR(X,80),!
I $G(APCLLSTP),'APCLSCRD S X="Listing of those NOT Screened" W $$CTR(X,80),!
;I $G(APCLLSTP) W !?35,"DATE",!,"PATIENT NAME",?22,"HRN",?29,"AGE",?35,"SCREENED",?44,"RESULT",?61,"CLINIC"
I $G(APCLLSTP) W !?35,"DATE",!,"PATIENT NAME",?22,"HRN",?29,"AGE",?35,"SCREENED",?55,"CLINIC"
W !,$TR($J("",80)," ","-")
I '$G(APCLLSTP) W !?46,"#",?53,"% of patients",$S(APCLTALP:" screened",1:"")
Q
DONE ;
K ^TMP($J)
K ^XTMP("APCLDE4",APCLJ,APCLH)
D EOP
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:IO'=IO(0)
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
W !
S DIR("A")="End of Report. Press Enter",DIR(0)="E" D ^DIR
Q
;----------
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")
;----------
LIST ;EP - called from xbdbque
S APCLPG=0 K APCLQUIT
S APCLLSTP=1,APCLSCRD=1
D HEADER
K ^TMP($J)
;resort by sort item
S DFN=0 F S DFN=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN)) Q:DFN'=+DFN S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN) D
.D @APCLSORT
.I APCLSORV="" S APCLSORV="--"
.S ^TMP($J,"PTS",APCLSORV,DFN)=APCLY
.Q
S APCLSORV="" F S APCLSORV=$O(^TMP($J,"PTS",APCLSORV)) Q:APCLSORV=""!($D(APCLQUIT)) D
.S DFN=0 F S DFN=$O(^TMP($J,"PTS",APCLSORV,DFN)) Q:DFN'=+DFN!($D(APCLQUIT)) D
..Q:$$ENDL
..S APCLY=^TMP($J,"PTS",APCLSORV,DFN)
..W !!,$E($P(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$P(APCLY,U,4),?33,$P(^DPT(DFN,0),U,2),?35,$$DT($P(APCLY,U,1)),?55,$E($P(APCLY,U,6),1,20)
..W !?3,"Type/Result: ",$P($P(APCLY,U,2),";")_" "_$P($P(APCLY,U,2),";",2)
..I $P(APCLY,U,12)]"" W !?3,"Comment: ",$P(APCLY,U,12)
..I $P(APCLY,U,20)="PCC" S APCLV=$P(APCLY,U,14) I APCLV,$D(^AUPNVPOV("AD",APCLV)) D
...S APCLC=0 W !?3,"DXs: "
...S APCLX=0 F S APCLX=$O(^AUPNVPOV("AD",APCLV,APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
....S APCLC=APCLC+1
....W:APCLC'=1 ! W ?8,$$VAL^XBDIQ1(9000010.07,APCLX,.01),?17,$E($$VAL^XBDIQ1(9000010.07,APCLX,.04),1,60)
..I $P(APCLY,U,20)="BH" S APCLV=$P(APCLY,U,15) I APCLV,$D(^AMHRPRO("AD",APCLV)) D
...S APCLC=0 W !?3,"DXs: "
...S APCLX=0 F S APCLX=$O(^AMHRPRO("AD",APCLV,APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
....S APCLC=APCLC+1
....W:APCLC'=1 ! W ?8,$$VAL^XBDIQ1(9002011.01,APCLX,.01),?17,$E($$VAL^XBDIQ1(9002011.01,APCLX,.04),1,60)
..W !?3,"Primary Provider on Visit: ",?31,$P(APCLY,U,7)
..W !?3," Provider who screened: ",?31,$P(APCLY,U,5)
..I 'APCLDP W ! Q
..K APCLX S X=$$VAL^XBDIQ1(9002011.55,DFN,.02) I X]"" S APCLX("MENTAL HEALTH")=X
..S X=$$VAL^XBDIQ1(9002011.55,DFN,.03) I X]"" S APCLX("SOCIAL SERVICES")=X
..S X=$$VAL^XBDIQ1(9002011.55,DFN,.04) I X]"" S APCLX("CHEMICAL DEPENDENCY")=X
..S X=$$VAL^XBDIQ1(9000001,DFN,.14) I X]"" S APCLX("DESIGNATED PRIMARY PROVIDER")=X
..S APCLXX=0 F S APCLXX=$O(^BDPRECN("C",DFN,APCLXX)) Q:APCLXX'=+APCLXX D
...S A=$$VAL^XBDIQ1(90360.1,APCLXX,.01) I '$D(APCLX(A)) S APCLX(A)=$$VAL^XBDIQ1(90360.1,APCLXX,.03)
..Q:'$D(APCLX)
..W !?3," Designated Providers: "
..S APCLX="",APCLC=0 F S APCLX=$O(APCLX(APCLX)) Q:APCLX=""!($D(APCLQUIT)) D
...Q:$$END
...S APCLC=APCLC+1
...W:APCLC'=1 ! W ?31,$S(APCLX="DESIGNATED PRIMARY PROVIDER":"PRIMARY CARE",1:APCLX),": ",APCLX(APCLX)
S APCLSCRD=0
D HEADER
S DFN=0 F S DFN=$O(^DIBT(APCLSEAT,1,DFN)) Q:DFN'=+DFN!($D(APCLQUIT)) D
.Q:$D(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN))
.Q:$$END
.W !,$E($P(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$AGE^AUPNPAT(DFN,DT),?33,$P(^DPT(DFN,0),U,2)
Q
H ;
S APCLSORV=$$HRN^AUPNPAT(DFN,DUZ(2))
Q
N ;
S APCLSORV=$P(^DPT(DFN,0),U)
Q
P ;
S APCLSORV=$P(APCLY,U,5)
Q
R ;
S APCLSORV=$P($P(APCLY,U,2),";")_" "_$P($P(APCLY,U,2),";",2)
Q
D ;
S APCLSORV=$P(APCLY,U,1)
Q
A S APCLSORV=$P(APCLY,U,4)
Q
G ;
S APCLSORV=$P(APCLY,U,3)
Q
C ;
S APCLSORV=$P(APCLY,U,6)
Q
T ;
S %=$$HRN^AUPNPAT(DFN,DUZ(2))
S %=%+10000000,%=$E(%,7,8)_"-"_+$E(%,2,8)
S APCLSORV=%
Q
DT(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
APCLDE4P ; IHS/CMI/LAB - list refusals ;
+1 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+2 ;
+3 ;
PRINT ;EP - called from xbdbque
+1 DO PRINT1
+2 DO DONE
+3 QUIT
PRINT1 ;
+1 SET APCLPG=0
KILL APCLQUIT
+2 KILL APCLLSTP
SET APCLTALP=0
+3 IF '$DATA(^XTMP("APCLDE4",APCLJ,APCLH))
DO HEADER
WRITE !!,"No data to report.",!
GOTO DONE
+4 DO HEADER
+5 SET APCLPTOT=$$PTOT
+6 WRITE !," Total Number of Patients in TEMPLATE:",?40,$JUSTIFY($$COM(APCLPTOT,0),8)
+7 SET APCLTOT=$$TOT
+8 WRITE !!," Total Number of Patients screened",?40,$JUSTIFY($$COM(APCLTOT,0),8),?55,$$PER(APCLTOT,APCLPTOT)
+9 SET APCLTALP=1
+10 WRITE !!?46,"#",?53,"% of patients",$SELECT(APCLTALP:" screened",1:"")
+11 DO RES
+12 IF $$END
QUIT
+13 DO GENDER
+14 IF $$END
QUIT
+15 DO AGE
+16 IF $$END
QUIT
+17 DO PRVSC
+18 IF $$END
QUIT
+19 DO PRVV
+20 IF $$END
QUIT
+21 DO DESPRV
+22 IF $$END
QUIT
+23 DO CLINIC
+24 IF $$END
QUIT
+25 DO DATE
+26 IF $$END
QUIT
+27 DO MH
+28 IF $$END
QUIT
+29 DO SS
+30 IF $$END
QUIT
+31 DO CD
+32 IF $$END
QUIT
+33 KILL ^TMP($JOB)
+34 IF APCLLIST
DO LIST
+35 QUIT
RES ;
+1 IF '$DATA(APCLTALL(1))
QUIT
+2 ;TALLY BY RESULT FIRST
+3 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+5 SET R=$PIECE(APCLY,U,2)
SET R=$PIECE(R,";")_" "_$PIECE(R,";",2)
IF R=""
SET R="NO RESULT RECORDED"
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+6 WRITE !
+7 WRITE !," By Result",!
+8 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+9 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+10 QUIT
GENDER ;
+1 IF '$DATA(APCLTALL(2))
QUIT
+2 ;TALLY BY GENDER OF PATIENT
+3 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+5 SET R=$PIECE(APCLY,U,3)
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+6 WRITE !
+7 WRITE !," By Gender",!
+8 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+9 IF $$END
QUIT
+10 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
+11 QUIT
End DoDot:1
+12 QUIT
AGE ;
+1 IF '$DATA(APCLTALL(3))
QUIT
+2 ;TALLY BY age OF PATIENT
+3 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+5 SET R=$PIECE(APCLY,U,4)
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+6 WRITE !
+7 WRITE !," By Age",!
+8 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+9 IF $$END
QUIT
+10 SET Y=$LENGTH(APCLX_" yrs")
SET Y=38-Y
WRITE !?Y,APCLX," yrs",?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+11 QUIT
PRVSC ;
+1 IF '$DATA(APCLTALL(4))
QUIT
+2 ;TALLY BY PRIMARY provider OF service
+3 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+5 SET R=$PIECE(APCLY,U,5)
IF R=""
SET R="UNKNOWN"
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+6 WRITE !
+7 WRITE !," By Provider who screened",!
+8 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+9 IF $$END
QUIT
+10 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+11 QUIT
PRVV ;
+1 IF '$DATA(APCLTALL(7))
QUIT
+2 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+4 SET R=$PIECE(APCLY,U,7)
IF R=""
SET R="UNKNOWN"
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+5 WRITE !
+6 WRITE !," By Primary Provider of Visit",!
+7 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+8 IF $$END
QUIT
+9 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+10 QUIT
DESPRV ;
+1 IF '$DATA(APCLTALL(11))
QUIT
+2 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+4 SET R=$PIECE(APCLY,U,11)
IF R=""
SET R="UNKNOWN"
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+5 WRITE !
+6 WRITE !," By Designated Primary Care Provider",!
+7 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+8 IF $$END
QUIT
+9 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+10 QUIT
MH ;
+1 IF '$DATA(APCLTALL(8))
QUIT
+2 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+4 SET R=$PIECE(APCLY,U,8)
IF R=""
SET R="UNKNOWN"
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+5 WRITE !
+6 WRITE !," By Designated Mental Health Provider",!
+7 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+8 IF $$END
QUIT
+9 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+10 QUIT
SS ;
+1 IF '$DATA(APCLTALL(9))
QUIT
+2 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+4 SET R=$PIECE(APCLY,U,9)
IF R=""
SET R="UNKNOWN"
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+5 WRITE !
+6 WRITE !," By Designated Social Services Provider",!
+7 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+8 IF $$END
QUIT
+9 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+10 QUIT
CD ;
+1 IF '$DATA(APCLTALL(10))
QUIT
+2 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+4 SET R=$PIECE(APCLY,U,10)
IF R=""
SET R="UNKNOWN"
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+5 WRITE !
+6 WRITE !," By Designated A/SA Provider",!
+7 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+8 IF $$END
QUIT
+9 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+10 QUIT
CLINIC ;
+1 IF '$DATA(APCLTALL(5))
QUIT
+2 ;TALLY BY clinic
+3 KILL APCLRES
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+5 SET R=$PIECE(APCLY,U,6)
IF R=""
SET R="UNKNOWN"
SET APCLRES(R)=$GET(APCLRES(R))+1
End DoDot:1
+6 WRITE !
+7 WRITE !," By Clinic",!
+8 SET APCLX=""
FOR
SET APCLX=$ORDER(APCLRES(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+9 IF $$END
QUIT
+10 SET Y=$LENGTH(APCLX)
SET Y=38-Y
WRITE !?Y,APCLX,?40,$JUSTIFY($$COM($GET(APCLRES(APCLX)),0),8),?55,$$PER(APCLRES(APCLX),APCLTOT)
KILL APCLRES(APCLX)
End DoDot:1
+11 QUIT
DATE ;
+1 IF '$DATA(APCLTALL(6))
QUIT
+2 ;TALLY BY date OF service
+3 KILL ^TMP($JOB)
SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;S D=$O(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,""),-1) S APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X,D)
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X)
+5 SET R=$PIECE(APCLY,U,1)
SET ^TMP($JOB,R)=$GET(^TMP($JOB,R))+1
End DoDot:1
+6 WRITE !
+7 WRITE !," By Date",!
+8 SET APCLX=""
FOR
SET APCLX=$ORDER(^TMP($JOB,APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+9 IF $$END
QUIT
+10 SET Y=$LENGTH($$FMTE^XLFDT(APCLX))
SET Y=38-Y
WRITE !?Y,$$FMTE^XLFDT(APCLX),?40,$JUSTIFY($$COM($GET(^TMP($JOB,APCLX)),0),8),?55,$$PER(^TMP($JOB,APCLX),APCLTOT)
KILL ^TMP($JOB,APCLX)
End DoDot:1
+11 QUIT
+12 ;
PER(N,D) ;return % of n/d
+1 IF 'D
QUIT "0%"
+2 NEW Z
+3 SET Z=N/D
SET Z=Z*100
SET Z=$JUSTIFY(Z,5,1)
+4 QUIT $$STRIP^XLFSTR(Z," ")_"%"
COM(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT $$STRIP^XLFSTR(X," ")
END() ;
+1 IF $Y<(IOSL-3)
QUIT 0
+2 DO HEADER
+3 IF $DATA(APCLQUIT)
QUIT 1
+4 QUIT 0
ENDL() ;
+1 IF $Y<(IOSL-8)
QUIT 0
+2 DO HEADER
+3 IF $DATA(APCLQUIT)
QUIT 1
+4 QUIT 0
TOT() ;
+1 NEW C,X
+2 SET C=0
+3 SET X=0
FOR
SET X=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",X))
IF X'=+X
QUIT
SET C=C+1
+4 QUIT C
PTOT() ;
+1 NEW C,X
+2 SET C=0
+3 SET X=0
FOR
SET X=$ORDER(^DIBT(APCLSEAT,1,X))
IF X'=+X
QUIT
SET C=C+1
+4 QUIT C
+1 IF 'APCLPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQUIT=""
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!
+3 WRITE !,$$CTR("*** DEPRESSION SCREENING PATIENT TALLY"_$SELECT(APCLLIST:" AND PATIENT LISTING",1:"")_" ***",80),!
+4 SET X="Screening Dates: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED)
WRITE $$CTR(X,80),!
+5 IF APCLEXPC
SET X="This report includes data from the BH Clinics"
WRITE $$CTR(X,80),!
+6 IF 'APCLEXPC
SET X="This report excludes data from the BH Clinics"
WRITE $$CTR(X,80),!
+7 SET X="SEARCH TEMPLATE OF PATIENTS: "_$PIECE(^DIBT(APCLSEAT,0),U)
WRITE $$CTR(X,80),!
+8 IF $GET(APCLLSTP)
IF APCLSCRD
SET X="Listing of those patients screened"
WRITE $$CTR(X,80),!
+9 IF $GET(APCLLSTP)
IF 'APCLSCRD
SET X="Listing of those NOT Screened"
WRITE $$CTR(X,80),!
+10 ;I $G(APCLLSTP) W !?35,"DATE",!,"PATIENT NAME",?22,"HRN",?29,"AGE",?35,"SCREENED",?44,"RESULT",?61,"CLINIC"
+11 IF $GET(APCLLSTP)
WRITE !?35,"DATE",!,"PATIENT NAME",?22,"HRN",?29,"AGE",?35,"SCREENED",?55,"CLINIC"
+12 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+13 IF '$GET(APCLLSTP)
WRITE !?46,"#",?53,"% of patients",$SELECT(APCLTALP:" screened",1:"")
+14 QUIT
DONE ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("APCLDE4",APCLJ,APCLH)
+3 DO EOP
+4 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 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF IO'=IO(0)
QUIT
+3 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+4 NEW DIR
+5 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+6 WRITE !
+7 SET DIR("A")="End of Report. Press Enter"
SET DIR(0)="E"
DO ^DIR
+8 QUIT
+9 ;----------
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 ;----------
LIST ;EP - called from xbdbque
+1 SET APCLPG=0
KILL APCLQUIT
+2 SET APCLLSTP=1
SET APCLSCRD=1
+3 DO HEADER
+4 KILL ^TMP($JOB)
+5 ;resort by sort item
+6 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN))
IF DFN'=+DFN
QUIT
SET APCLY=^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN)
Begin DoDot:1
+7 DO @APCLSORT
+8 IF APCLSORV=""
SET APCLSORV="--"
+9 SET ^TMP($JOB,"PTS",APCLSORV,DFN)=APCLY
+10 QUIT
End DoDot:1
+11 SET APCLSORV=""
FOR
SET APCLSORV=$ORDER(^TMP($JOB,"PTS",APCLSORV))
IF APCLSORV=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+12 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"PTS",APCLSORV,DFN))
IF DFN'=+DFN!($DATA(APCLQUIT))
QUIT
Begin DoDot:2
+13 IF $$ENDL
QUIT
+14 SET APCLY=^TMP($JOB,"PTS",APCLSORV,DFN)
+15 WRITE !!,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$PIECE(APCLY,U,4),?33,$PIECE(^DPT(DFN,0),U,2),?35,$$DT($PIECE(APCLY,U,1)),?55,$EXTRACT($PIECE(APCLY,U,6),1,20)
+16 WRITE !?3,"Type/Result: ",$PIECE($PIECE(APCLY,U,2),";")_" "_$PIECE($PIECE(APCLY,U,2),";",2)
+17 IF $PIECE(APCLY,U,12)]""
WRITE !?3,"Comment: ",$PIECE(APCLY,U,12)
+18 IF $PIECE(APCLY,U,20)="PCC"
SET APCLV=$PIECE(APCLY,U,14)
IF APCLV
IF $DATA(^AUPNVPOV("AD",APCLV))
Begin DoDot:3
+19 SET APCLC=0
WRITE !?3,"DXs: "
+20 SET APCLX=0
FOR
SET APCLX=$ORDER(^AUPNVPOV("AD",APCLV,APCLX))
IF APCLX'=+APCLX!($DATA(APCLQUIT))
QUIT
Begin DoDot:4
+21 SET APCLC=APCLC+1
+22 IF APCLC'=1
WRITE !
WRITE ?8,$$VAL^XBDIQ1(9000010.07,APCLX,.01),?17,$EXTRACT($$VAL^XBDIQ1(9000010.07,APCLX,.04),1,60)
End DoDot:4
End DoDot:3
+23 IF $PIECE(APCLY,U,20)="BH"
SET APCLV=$PIECE(APCLY,U,15)
IF APCLV
IF $DATA(^AMHRPRO("AD",APCLV))
Begin DoDot:3
+24 SET APCLC=0
WRITE !?3,"DXs: "
+25 SET APCLX=0
FOR
SET APCLX=$ORDER(^AMHRPRO("AD",APCLV,APCLX))
IF APCLX'=+APCLX!($DATA(APCLQUIT))
QUIT
Begin DoDot:4
+26 SET APCLC=APCLC+1
+27 IF APCLC'=1
WRITE !
WRITE ?8,$$VAL^XBDIQ1(9002011.01,APCLX,.01),?17,$EXTRACT($$VAL^XBDIQ1(9002011.01,APCLX,.04),1,60)
End DoDot:4
End DoDot:3
+28 WRITE !?3,"Primary Provider on Visit: ",?31,$PIECE(APCLY,U,7)
+29 WRITE !?3," Provider who screened: ",?31,$PIECE(APCLY,U,5)
+30 IF 'APCLDP
WRITE !
QUIT
+31 KILL APCLX
SET X=$$VAL^XBDIQ1(9002011.55,DFN,.02)
IF X]""
SET APCLX("MENTAL HEALTH")=X
+32 SET X=$$VAL^XBDIQ1(9002011.55,DFN,.03)
IF X]""
SET APCLX("SOCIAL SERVICES")=X
+33 SET X=$$VAL^XBDIQ1(9002011.55,DFN,.04)
IF X]""
SET APCLX("CHEMICAL DEPENDENCY")=X
+34 SET X=$$VAL^XBDIQ1(9000001,DFN,.14)
IF X]""
SET APCLX("DESIGNATED PRIMARY PROVIDER")=X
+35 SET APCLXX=0
FOR
SET APCLXX=$ORDER(^BDPRECN("C",DFN,APCLXX))
IF APCLXX'=+APCLXX
QUIT
Begin DoDot:3
+36 SET A=$$VAL^XBDIQ1(90360.1,APCLXX,.01)
IF '$DATA(APCLX(A))
SET APCLX(A)=$$VAL^XBDIQ1(90360.1,APCLXX,.03)
End DoDot:3
+37 IF '$DATA(APCLX)
QUIT
+38 WRITE !?3," Designated Providers: "
+39 SET APCLX=""
SET APCLC=0
FOR
SET APCLX=$ORDER(APCLX(APCLX))
IF APCLX=""!($DATA(APCLQUIT))
QUIT
Begin DoDot:3
+40 IF $$END
QUIT
+41 SET APCLC=APCLC+1
+42 IF APCLC'=1
WRITE !
WRITE ?31,$SELECT(APCLX="DESIGNATED PRIMARY PROVIDER":"PRIMARY CARE",1:APCLX),": ",APCLX(APCLX)
End DoDot:3
End DoDot:2
End DoDot:1
+43 SET APCLSCRD=0
+44 DO HEADER
+45 SET DFN=0
FOR
SET DFN=$ORDER(^DIBT(APCLSEAT,1,DFN))
IF DFN'=+DFN!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+46 IF $DATA(^XTMP("APCLDE4",APCLJ,APCLH,"PTS",DFN))
QUIT
+47 IF $$END
QUIT
+48 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$AGE^AUPNPAT(DFN,DT),?33,$PIECE(^DPT(DFN,0),U,2)
End DoDot:1
+49 QUIT
H ;
+1 SET APCLSORV=$$HRN^AUPNPAT(DFN,DUZ(2))
+2 QUIT
N ;
+1 SET APCLSORV=$PIECE(^DPT(DFN,0),U)
+2 QUIT
P ;
+1 SET APCLSORV=$PIECE(APCLY,U,5)
+2 QUIT
R ;
+1 SET APCLSORV=$PIECE($PIECE(APCLY,U,2),";")_" "_$PIECE($PIECE(APCLY,U,2),";",2)
+2 QUIT
D ;
+1 SET APCLSORV=$PIECE(APCLY,U,1)
+2 QUIT
A SET APCLSORV=$PIECE(APCLY,U,4)
+1 QUIT
G ;
+1 SET APCLSORV=$PIECE(APCLY,U,3)
+2 QUIT
C ;
+1 SET APCLSORV=$PIECE(APCLY,U,6)
+2 QUIT
T ;
+1 SET %=$$HRN^AUPNPAT(DFN,DUZ(2))
+2 SET %=%+10000000
SET %=$EXTRACT(%,7,8)_"-"_+$EXTRACT(%,2,8)
+3 SET APCLSORV=%
+4 QUIT
DT(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
