- AMHRAS1P ; IHS/CMI/LAB - list refusals ;
- ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
- ;
- ;
- PRINT ;EP - called from xbdbque
- D PRINT1
- D DONE
- Q
- PRINT1 ;
- S AMHRPG=0 K AMHRQUIT
- K AMHRLSTP
- I '$D(^XTMP("AMHRAS1",AMHRJ,AMHRH)) D HEADER W !!,"No data to report.",! G DONE
- D HEADER
- S AMHRTOT=$$TOT
- W !," Total Number of Patients screened",?40,$J($$COM(AMHRTOT,0),8)
- 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 AMHRLIST D LIST
- Q
- RES ;
- Q:'$D(AMHRTALL(1))
- ;TALLY BY RESULT FIRST
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,2) S R=$P(R,";")_" "_$P(R,";",2) S:R="" R="NO RESULT RECORDED" S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Result",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- GENDER ;
- Q:'$D(AMHRTALL(2))
- ;TALLY BY GENDER OF PATIENT
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,3) S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Gender",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- .Q
- Q
- AGE ;
- Q:'$D(AMHRTALL(3))
- ;TALLY BY age OF PATIENT
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,4) S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Age",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX_" yrs"),Y=38-Y W !?Y,AMHRX," yrs",?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- PRVSC ;
- Q:'$D(AMHRTALL(4))
- ;TALLY BY PRIMARY provider OF service
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,5) S:R="" R="UNKNOWN" S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Provider who screened",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- PRVV ;
- Q:'$D(AMHRTALL(7))
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,7) S:R="" R="UNKNOWN" S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Primary Provider of Visit",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- DESPRV ;
- Q:'$D(AMHRTALL(11))
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,11) S:R="" R="UNKNOWN" S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Designated Primary Care Provider",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- MH ;
- Q:'$D(AMHRTALL(8))
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,8) S:R="" R="UNKNOWN" S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Designated Mental Health Provider",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- SS ;
- Q:'$D(AMHRTALL(9))
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,9) S:R="" R="UNKNOWN" S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Designated Social Services Provider",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- CD ;
- Q:'$D(AMHRTALL(10))
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,10) S:R="" R="UNKNOWN" S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Designated A/SA Provider",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- CLINIC ;
- Q:'$D(AMHRTALL(5))
- ;TALLY BY clinic
- K AMHRRES S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,6) S:R="" R="UNKNOWN" S AMHRRES(R)=$G(AMHRRES(R))+1
- W !
- W !," By Clinic",!
- S AMHRX="" F S AMHRX=$O(AMHRRES(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L(AMHRX),Y=38-Y W !?Y,AMHRX,?40,$J($$COM($G(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT) K AMHRRES(AMHRX)
- Q
- DATE ;
- Q:'$D(AMHRTALL(6))
- ;TALLY BY date OF service
- K ^TMP($J) S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X D
- .S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X) ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- .S R=$P(AMHRY,U,1) S ^TMP($J,R)=$G(^TMP($J,R))+1
- W !
- W !," By Date",!
- S AMHRX="" F S AMHRX=$O(^TMP($J,AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- .Q:$$END
- .S Y=$L($$FMTE^XLFDT(AMHRX)),Y=38-Y W !?Y,$$FMTE^XLFDT(AMHRX),?40,$J($$COM($G(^TMP($J,AMHRX)),0),8),?55,$$PER(^TMP($J,AMHRX),AMHRTOT) K ^TMP($J,AMHRX)
- 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(AMHRQUIT) Q 1
- Q 0
- ENDL() ;
- I $Y<(IOSL-8) Q 0
- D HEADER
- I $D(AMHRQUIT) Q 1
- Q 0
- TOT() ;
- NEW C,X
- S C=0
- S X=0 F S X=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)) Q:X'=+X S C=C+1
- Q C
- G:'AMHRPG 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 AMHRQUIT="" Q
- W:$D(IOF) @IOF S AMHRPG=AMHRPG+1
- W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",AMHRPG,!
- W !,$$CTR("*** ALCOHOL SCREENING PATIENT TALLY"_$S(AMHRLIST:" AND PATIENT LISTING",1:"")_" ***",80),!
- S X="Screening Dates: "_$$FMTE^XLFDT(AMHRBD)_" to "_$$FMTE^XLFDT(AMHRED) W $$CTR(X,80),!
- I AMHREXPC S X="This report includes data from the PCC Clinical database" W $$CTR(X,80),!
- I 'AMHREXPC S X="This report excludes data from the PCC Clinical database" W $$CTR(X,80),!
- I $G(AMHRLSTP) W !?35,"DATE",!,"PATIENT NAME",?22,"HRN",?29,"AGE",?35,"SCREENED",?55,"CLINIC"
- W !,$TR($J("",80)," ","-")
- I '$G(AMHRLSTP) W !?46,"#",?53,"% of patients"
- Q
- DONE ;
- K ^TMP($J)
- K ^XTMP("AMHRAS1",AMHRJ,AMHRH)
- 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 AMHRPG=0 K AMHRQUIT
- S AMHRLSTP=1
- D HEADER
- K ^TMP($J)
- ;resort by sort item
- S DFN=0 F S DFN=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",DFN)) Q:DFN'=+DFN S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",DFN) D
- .D @AMHRSORT
- .I AMHRSORV="" S AMHRSORV="--"
- .S ^TMP($J,"PTS",AMHRSORV,DFN)=AMHRY
- .Q
- S AMHRSORV="" F S AMHRSORV=$O(^TMP($J,"PTS",AMHRSORV)) Q:AMHRSORV=""!($D(AMHRQUIT)) D
- .S DFN=0 F S DFN=$O(^TMP($J,"PTS",AMHRSORV,DFN)) Q:DFN'=+DFN!($D(AMHRQUIT)) D
- ..Q:$$ENDL
- ..S AMHRY=^TMP($J,"PTS",AMHRSORV,DFN)
- ..W !!,$E($P(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$P(AMHRY,U,4),?33,$P(^DPT(DFN,0),U,2),?35,$$DT($P(AMHRY,U,1)),?55,$E($P(AMHRY,U,6),1,20)
- ..W !?3,"Type/Result: ",$P($P(AMHRY,U,2),";")_" "_$P($P(AMHRY,U,2),";",2)
- ..I $P(AMHRY,U,12)]"" W !?3,"Comment: ",$P(AMHRY,U,12)
- ..I $P(AMHRY,U,20)="PCC" S AMHRV=$P(AMHRY,U,14) I AMHRV,$D(^AUPNVPOV("AD",AMHRV)) D
- ...S AMHRC=0 W !?3,"DXs: "
- ...S AMHRX=0 F S AMHRX=$O(^AUPNVPOV("AD",AMHRV,AMHRX)) Q:AMHRX'=+AMHRX!($D(AMHRQUIT)) D
- ....S AMHRC=AMHRC+1
- ....W:AMHRC'=1 ! W ?8,$$VAL^XBDIQ1(9000010.07,AMHRX,.01),?17,$E($$VAL^XBDIQ1(9000010.07,AMHRX,.04),1,60)
- ..I $P(AMHRY,U,20)="BH" S AMHRV=$P(AMHRY,U,13) I AMHRV,$D(^AMHRPRO("AD",AMHRV)) D
- ...S AMHRC=0 W !?3,"DXs: "
- ...S AMHRX=0 F S AMHRX=$O(^AMHRPRO("AD",AMHRV,AMHRX)) Q:AMHRX'=+AMHRX!($D(AMHRQUIT)) D
- ....S AMHRC=AMHRC+1
- ....W:AMHRC'=1 ! W ?8,$$VAL^XBDIQ1(9002011.01,AMHRX,.01),?17,$E($$VAL^XBDIQ1(9002011.01,AMHRX,.04),1,60)
- ..W !?3,"Primary Provider on Visit: ",?31,$P(AMHRY,U,7)
- ..W !?3," Provider who screened: ",?31,$P(AMHRY,U,5)
- ..I 'AMHRDP W ! Q
- ..K AMHRX S X=$$VAL^XBDIQ1(9002011.55,DFN,.02) I X]"" S AMHRX("MENTAL HEALTH")=X
- ..S X=$$VAL^XBDIQ1(9002011.55,DFN,.03) I X]"" S AMHRX("SOCIAL SERVICES")=X
- ..S X=$$VAL^XBDIQ1(9002011.55,DFN,.04) I X]"" S AMHRX("CHEMICAL DEPENDENCY")=X
- ..S X=$$VAL^XBDIQ1(9000001,DFN,.14) I X]"" S AMHRX("DESIGNATED PRIMARY PROVIDER")=X
- ..S AMHRXX=0 F S AMHRXX=$O(^BDPRECN("C",DFN,AMHRXX)) Q:AMHRXX'=+AMHRXX D
- ...S A=$$VAL^XBDIQ1(90360.1,AMHRXX,.01) I '$D(AMHRX(A)) S AMHRX(A)=$$VAL^XBDIQ1(90360.1,AMHRXX,.03)
- ..Q:'$D(AMHRX)
- ..W !?3," Designated Providers: "
- ..S AMHRX="",AMHRC=0 F S AMHRX=$O(AMHRX(AMHRX)) Q:AMHRX=""!($D(AMHRQUIT)) D
- ...Q:$$END
- ...S AMHRC=AMHRC+1
- ...W:AMHRC'=1 ! W ?31,$S(AMHRX="DESIGNATED PRIMARY PROVIDER":"PRIMARY CARE",1:AMHRX),": ",AMHRX(AMHRX)
- Q
- H ;
- S AMHRSORV=$$HRN^AUPNPAT(DFN,DUZ(2))
- Q
- N ;
- S AMHRSORV=$P(^DPT(DFN,0),U)
- Q
- P ;
- S AMHRSORV=$P(AMHRY,U,5)
- Q
- R ;
- S AMHRSORV=$P($P(AMHRY,U,2),";")_" "_$P($P(AMHRY,U,2),";",2)
- Q
- D ;
- S AMHRSORV=$P(AMHRY,U,1)
- Q
- A S AMHRSORV=$P(AMHRY,U,4)
- Q
- G ;
- S AMHRSORV=$P(AMHRY,U,3)
- Q
- C ;
- S AMHRSORV=$P(AMHRY,U,6)
- Q
- T ;
- S %=$$HRN^AUPNPAT(DFN,DUZ(2))
- S %=%+10000000,%=$E(%,7,8)_"-"_+$E(%,2,8)
- S AMHRSORV=%
- Q
- DT(D) ;EP
- I D="" Q ""
- Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
- ;
- AMHRAS1P ; IHS/CMI/LAB - list refusals ;
- +1 ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
- +2 ;
- +3 ;
- PRINT ;EP - called from xbdbque
- +1 DO PRINT1
- +2 DO DONE
- +3 QUIT
- PRINT1 ;
- +1 SET AMHRPG=0
- KILL AMHRQUIT
- +2 KILL AMHRLSTP
- +3 IF '$DATA(^XTMP("AMHRAS1",AMHRJ,AMHRH))
- DO HEADER
- WRITE !!,"No data to report.",!
- GOTO DONE
- +4 DO HEADER
- +5 SET AMHRTOT=$$TOT
- +6 WRITE !," Total Number of Patients screened",?40,$JUSTIFY($$COM(AMHRTOT,0),8)
- +7 DO RES
- +8 IF $$END
- QUIT
- +9 DO GENDER
- +10 IF $$END
- QUIT
- +11 DO AGE
- +12 IF $$END
- QUIT
- +13 DO PRVSC
- +14 IF $$END
- QUIT
- +15 DO PRVV
- +16 IF $$END
- QUIT
- +17 DO DESPRV
- +18 IF $$END
- QUIT
- +19 DO CLINIC
- +20 IF $$END
- QUIT
- +21 DO DATE
- +22 IF $$END
- QUIT
- +23 DO MH
- +24 IF $$END
- QUIT
- +25 DO SS
- +26 IF $$END
- QUIT
- +27 DO CD
- +28 IF $$END
- QUIT
- +29 KILL ^TMP($JOB)
- +30 IF AMHRLIST
- DO LIST
- +31 QUIT
- RES ;
- +1 IF '$DATA(AMHRTALL(1))
- QUIT
- +2 ;TALLY BY RESULT FIRST
- +3 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +4 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +5 SET R=$PIECE(AMHRY,U,2)
- SET R=$PIECE(R,";")_" "_$PIECE(R,";",2)
- IF R=""
- SET R="NO RESULT RECORDED"
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +6 WRITE !
- +7 WRITE !," By Result",!
- +8 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +9 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +10 QUIT
- GENDER ;
- +1 IF '$DATA(AMHRTALL(2))
- QUIT
- +2 ;TALLY BY GENDER OF PATIENT
- +3 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +4 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +5 SET R=$PIECE(AMHRY,U,3)
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +6 WRITE !
- +7 WRITE !," By Gender",!
- +8 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +9 IF $$END
- QUIT
- +10 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- +11 QUIT
- End DoDot:1
- +12 QUIT
- AGE ;
- +1 IF '$DATA(AMHRTALL(3))
- QUIT
- +2 ;TALLY BY age OF PATIENT
- +3 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +4 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +5 SET R=$PIECE(AMHRY,U,4)
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +6 WRITE !
- +7 WRITE !," By Age",!
- +8 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +9 IF $$END
- QUIT
- +10 SET Y=$LENGTH(AMHRX_" yrs")
- SET Y=38-Y
- WRITE !?Y,AMHRX," yrs",?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +11 QUIT
- PRVSC ;
- +1 IF '$DATA(AMHRTALL(4))
- QUIT
- +2 ;TALLY BY PRIMARY provider OF service
- +3 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +4 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +5 SET R=$PIECE(AMHRY,U,5)
- IF R=""
- SET R="UNKNOWN"
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +6 WRITE !
- +7 WRITE !," By Provider who screened",!
- +8 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +9 IF $$END
- QUIT
- +10 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +11 QUIT
- PRVV ;
- +1 IF '$DATA(AMHRTALL(7))
- QUIT
- +2 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +3 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +4 SET R=$PIECE(AMHRY,U,7)
- IF R=""
- SET R="UNKNOWN"
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +5 WRITE !
- +6 WRITE !," By Primary Provider of Visit",!
- +7 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +8 IF $$END
- QUIT
- +9 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +10 QUIT
- DESPRV ;
- +1 IF '$DATA(AMHRTALL(11))
- QUIT
- +2 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +3 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +4 SET R=$PIECE(AMHRY,U,11)
- IF R=""
- SET R="UNKNOWN"
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +5 WRITE !
- +6 WRITE !," By Designated Primary Care Provider",!
- +7 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +8 IF $$END
- QUIT
- +9 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +10 QUIT
- MH ;
- +1 IF '$DATA(AMHRTALL(8))
- QUIT
- +2 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +3 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +4 SET R=$PIECE(AMHRY,U,8)
- IF R=""
- SET R="UNKNOWN"
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +5 WRITE !
- +6 WRITE !," By Designated Mental Health Provider",!
- +7 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +8 IF $$END
- QUIT
- +9 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +10 QUIT
- SS ;
- +1 IF '$DATA(AMHRTALL(9))
- QUIT
- +2 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +3 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +4 SET R=$PIECE(AMHRY,U,9)
- IF R=""
- SET R="UNKNOWN"
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +5 WRITE !
- +6 WRITE !," By Designated Social Services Provider",!
- +7 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +8 IF $$END
- QUIT
- +9 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +10 QUIT
- CD ;
- +1 IF '$DATA(AMHRTALL(10))
- QUIT
- +2 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +3 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +4 SET R=$PIECE(AMHRY,U,10)
- IF R=""
- SET R="UNKNOWN"
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +5 WRITE !
- +6 WRITE !," By Designated A/SA Provider",!
- +7 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +8 IF $$END
- QUIT
- +9 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +10 QUIT
- CLINIC ;
- +1 IF '$DATA(AMHRTALL(5))
- QUIT
- +2 ;TALLY BY clinic
- +3 KILL AMHRRES
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +4 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +5 SET R=$PIECE(AMHRY,U,6)
- IF R=""
- SET R="UNKNOWN"
- SET AMHRRES(R)=$GET(AMHRRES(R))+1
- End DoDot:1
- +6 WRITE !
- +7 WRITE !," By Clinic",!
- +8 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(AMHRRES(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +9 IF $$END
- QUIT
- +10 SET Y=$LENGTH(AMHRX)
- SET Y=38-Y
- WRITE !?Y,AMHRX,?40,$JUSTIFY($$COM($GET(AMHRRES(AMHRX)),0),8),?55,$$PER(AMHRRES(AMHRX),AMHRTOT)
- KILL AMHRRES(AMHRX)
- End DoDot:1
- +11 QUIT
- DATE ;
- +1 IF '$DATA(AMHRTALL(6))
- QUIT
- +2 ;TALLY BY date OF service
- +3 KILL ^TMP($JOB)
- SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +4 ;S D=$O(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,""),-1) S AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X,D)
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X)
- +5 SET R=$PIECE(AMHRY,U,1)
- SET ^TMP($JOB,R)=$GET(^TMP($JOB,R))+1
- End DoDot:1
- +6 WRITE !
- +7 WRITE !," By Date",!
- +8 SET AMHRX=""
- FOR
- SET AMHRX=$ORDER(^TMP($JOB,AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +9 IF $$END
- QUIT
- +10 SET Y=$LENGTH($$FMTE^XLFDT(AMHRX))
- SET Y=38-Y
- WRITE !?Y,$$FMTE^XLFDT(AMHRX),?40,$JUSTIFY($$COM($GET(^TMP($JOB,AMHRX)),0),8),?55,$$PER(^TMP($JOB,AMHRX),AMHRTOT)
- KILL ^TMP($JOB,AMHRX)
- 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(AMHRQUIT)
- QUIT 1
- +4 QUIT 0
- ENDL() ;
- +1 IF $Y<(IOSL-8)
- QUIT 0
- +2 DO HEADER
- +3 IF $DATA(AMHRQUIT)
- QUIT 1
- +4 QUIT 0
- TOT() ;
- +1 NEW C,X
- +2 SET C=0
- +3 SET X=0
- FOR
- SET X=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",X))
- IF X'=+X
- QUIT
- SET C=C+1
- +4 QUIT C
- +1 IF 'AMHRPG
- 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 AMHRQUIT=""
- QUIT
- +1 IF $DATA(IOF)
- WRITE @IOF
- SET AMHRPG=AMHRPG+1
- +2 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",AMHRPG,!
- +3 WRITE !,$$CTR("*** ALCOHOL SCREENING PATIENT TALLY"_$SELECT(AMHRLIST:" AND PATIENT LISTING",1:"")_" ***",80),!
- +4 SET X="Screening Dates: "_$$FMTE^XLFDT(AMHRBD)_" to "_$$FMTE^XLFDT(AMHRED)
- WRITE $$CTR(X,80),!
- +5 IF AMHREXPC
- SET X="This report includes data from the PCC Clinical database"
- WRITE $$CTR(X,80),!
- +6 IF 'AMHREXPC
- SET X="This report excludes data from the PCC Clinical database"
- WRITE $$CTR(X,80),!
- +7 IF $GET(AMHRLSTP)
- WRITE !?35,"DATE",!,"PATIENT NAME",?22,"HRN",?29,"AGE",?35,"SCREENED",?55,"CLINIC"
- +8 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
- +9 IF '$GET(AMHRLSTP)
- WRITE !?46,"#",?53,"% of patients"
- +10 QUIT
- DONE ;
- +1 KILL ^TMP($JOB)
- +2 KILL ^XTMP("AMHRAS1",AMHRJ,AMHRH)
- +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 AMHRPG=0
- KILL AMHRQUIT
- +2 SET AMHRLSTP=1
- +3 DO HEADER
- +4 KILL ^TMP($JOB)
- +5 ;resort by sort item
- +6 SET DFN=0
- FOR
- SET DFN=$ORDER(^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",DFN))
- IF DFN'=+DFN
- QUIT
- SET AMHRY=^XTMP("AMHRAS1",AMHRJ,AMHRH,"PTS",DFN)
- Begin DoDot:1
- +7 DO @AMHRSORT
- +8 IF AMHRSORV=""
- SET AMHRSORV="--"
- +9 SET ^TMP($JOB,"PTS",AMHRSORV,DFN)=AMHRY
- +10 QUIT
- End DoDot:1
- +11 SET AMHRSORV=""
- FOR
- SET AMHRSORV=$ORDER(^TMP($JOB,"PTS",AMHRSORV))
- IF AMHRSORV=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:1
- +12 SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP($JOB,"PTS",AMHRSORV,DFN))
- IF DFN'=+DFN!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:2
- +13 IF $$ENDL
- QUIT
- +14 SET AMHRY=^TMP($JOB,"PTS",AMHRSORV,DFN)
- +15 WRITE !!,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$PIECE(AMHRY,U,4),?33,$PIECE(^DPT(DFN,0),U,2),?35,$$DT($PIECE(AMHRY,U,1)),?55,$EXTRACT($PIECE(AMHRY,U,6),1,20)
- +16 WRITE !?3,"Type/Result: ",$PIECE($PIECE(AMHRY,U,2),";")_" "_$PIECE($PIECE(AMHRY,U,2),";",2)
- +17 IF $PIECE(AMHRY,U,12)]""
- WRITE !?3,"Comment: ",$PIECE(AMHRY,U,12)
- +18 IF $PIECE(AMHRY,U,20)="PCC"
- SET AMHRV=$PIECE(AMHRY,U,14)
- IF AMHRV
- IF $DATA(^AUPNVPOV("AD",AMHRV))
- Begin DoDot:3
- +19 SET AMHRC=0
- WRITE !?3,"DXs: "
- +20 SET AMHRX=0
- FOR
- SET AMHRX=$ORDER(^AUPNVPOV("AD",AMHRV,AMHRX))
- IF AMHRX'=+AMHRX!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:4
- +21 SET AMHRC=AMHRC+1
- +22 IF AMHRC'=1
- WRITE !
- WRITE ?8,$$VAL^XBDIQ1(9000010.07,AMHRX,.01),?17,$EXTRACT($$VAL^XBDIQ1(9000010.07,AMHRX,.04),1,60)
- End DoDot:4
- End DoDot:3
- +23 IF $PIECE(AMHRY,U,20)="BH"
- SET AMHRV=$PIECE(AMHRY,U,13)
- IF AMHRV
- IF $DATA(^AMHRPRO("AD",AMHRV))
- Begin DoDot:3
- +24 SET AMHRC=0
- WRITE !?3,"DXs: "
- +25 SET AMHRX=0
- FOR
- SET AMHRX=$ORDER(^AMHRPRO("AD",AMHRV,AMHRX))
- IF AMHRX'=+AMHRX!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:4
- +26 SET AMHRC=AMHRC+1
- +27 IF AMHRC'=1
- WRITE !
- WRITE ?8,$$VAL^XBDIQ1(9002011.01,AMHRX,.01),?17,$EXTRACT($$VAL^XBDIQ1(9002011.01,AMHRX,.04),1,60)
- End DoDot:4
- End DoDot:3
- +28 WRITE !?3,"Primary Provider on Visit: ",?31,$PIECE(AMHRY,U,7)
- +29 WRITE !?3," Provider who screened: ",?31,$PIECE(AMHRY,U,5)
- +30 IF 'AMHRDP
- WRITE !
- QUIT
- +31 KILL AMHRX
- SET X=$$VAL^XBDIQ1(9002011.55,DFN,.02)
- IF X]""
- SET AMHRX("MENTAL HEALTH")=X
- +32 SET X=$$VAL^XBDIQ1(9002011.55,DFN,.03)
- IF X]""
- SET AMHRX("SOCIAL SERVICES")=X
- +33 SET X=$$VAL^XBDIQ1(9002011.55,DFN,.04)
- IF X]""
- SET AMHRX("CHEMICAL DEPENDENCY")=X
- +34 SET X=$$VAL^XBDIQ1(9000001,DFN,.14)
- IF X]""
- SET AMHRX("DESIGNATED PRIMARY PROVIDER")=X
- +35 SET AMHRXX=0
- FOR
- SET AMHRXX=$ORDER(^BDPRECN("C",DFN,AMHRXX))
- IF AMHRXX'=+AMHRXX
- QUIT
- Begin DoDot:3
- +36 SET A=$$VAL^XBDIQ1(90360.1,AMHRXX,.01)
- IF '$DATA(AMHRX(A))
- SET AMHRX(A)=$$VAL^XBDIQ1(90360.1,AMHRXX,.03)
- End DoDot:3
- +37 IF '$DATA(AMHRX)
- QUIT
- +38 WRITE !?3," Designated Providers: "
- +39 SET AMHRX=""
- SET AMHRC=0
- FOR
- SET AMHRX=$ORDER(AMHRX(AMHRX))
- IF AMHRX=""!($DATA(AMHRQUIT))
- QUIT
- Begin DoDot:3
- +40 IF $$END
- QUIT
- +41 SET AMHRC=AMHRC+1
- +42 IF AMHRC'=1
- WRITE !
- WRITE ?31,$SELECT(AMHRX="DESIGNATED PRIMARY PROVIDER":"PRIMARY CARE",1:AMHRX),": ",AMHRX(AMHRX)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +43 QUIT
- H ;
- +1 SET AMHRSORV=$$HRN^AUPNPAT(DFN,DUZ(2))
- +2 QUIT
- N ;
- +1 SET AMHRSORV=$PIECE(^DPT(DFN,0),U)
- +2 QUIT
- P ;
- +1 SET AMHRSORV=$PIECE(AMHRY,U,5)
- +2 QUIT
- R ;
- +1 SET AMHRSORV=$PIECE($PIECE(AMHRY,U,2),";")_" "_$PIECE($PIECE(AMHRY,U,2),";",2)
- +2 QUIT
- D ;
- +1 SET AMHRSORV=$PIECE(AMHRY,U,1)
- +2 QUIT
- A SET AMHRSORV=$PIECE(AMHRY,U,4)
- +1 QUIT
- G ;
- +1 SET AMHRSORV=$PIECE(AMHRY,U,3)
- +2 QUIT
- C ;
- +1 SET AMHRSORV=$PIECE(AMHRY,U,6)
- +2 QUIT
- T ;
- +1 SET %=$$HRN^AUPNPAT(DFN,DUZ(2))
- +2 SET %=%+10000000
- SET %=$EXTRACT(%,7,8)_"-"_+$EXTRACT(%,2,8)
- +3 SET AMHRSORV=%
- +4 QUIT
- DT(D) ;EP
- +1 IF D=""
- QUIT ""
- +2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
- +3 ;