AMHRSR1 ; IHS/CMI/LAB - list SUICIDE RISK ASSESSMENT 24 Aug 2009 6:21 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
;
;
INFORM ;
W !,$$CTR($$USR)
W !,$$LOC()
W !!,$$CTR("TALLY AND LISTING OF PATIENTS RECEIVING SUICIDE RISK ",80),!,$$CTR("ASSESSMENT, INCLUDING REFUSALS",80)
W !!,"This report will tally and optionally list all patients who have had "
W !,"a Suicide Risk Assessment or a refusal documented in the time frame"
W !,"specified by the user. Suicide Risk Assessment is defined as any of the"
W !,"following documented: "
W !?10,"- Suicide Risk Assessment (Exam code 43)"
W !?10,"- refusal of exam code 43"
W !,"This report will tally the patients by age, gender, screening exam result, "
W !,"provider (either exam provider, if available, or primary provider on the visit),"
W !,"clinic, date of screening, designated PCP, MH Provider, SS Provider and A/SA"
W !,"Provider."
W !," Notes: "
W !?10,"- the last screening/refusal for each patient is used. If a patient"
W !?10," was screened more than once in the time period, only the latest"
W !?10," is used in this report."
W !?10,"- this report will optionally, look at both PCC and the Behavioral"
W !?10," Health databases for evidence of screening/refusal"
W !?10,"- this is a tally of Patients, not visits or screenings"
W !
D PAUSE^AMHLEA
D DBHUSR^AMHUTIL
D XIT
S AMHREXC=$O(^AUTTEXAM("C",43,0))
I 'AMHREXC W !!,"Exam code 43 is missing from the EXAM table. Cannot run report.",! H 3 D XIT Q
;
DATES K AMHRED,AMHRBD
W !,"Please enter the date range during which the screening was done.",!,"To get all screenings ever put in a long date range like 01/01/1980 ",!,"to the present date.",!
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date for Screening"
D ^DIR Q:Y<1 S AMHRBD=Y
K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date for Screening"
D ^DIR Q:Y<1 S AMHRED=Y
;
I AMHRED<AMHRBD D G DATES
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
;
TALLY ;which items to tally
K AMHRTALL
W !!,"Please select which items you wish to tally on this report:",!
W !?3,"0) Do not include any Tallies",?40,"6) Date of Screening"
W !?3,"1) Result of Assessment",?40,"7) Primary Provider on Visit"
W !?3,"2) Gender",?40,"8) Designated MH Provider"
W !?3,"3) Age of Patient",?40,"9) Designated SS Provider"
W !?3,"4) Provider who Screened",?40,"10) Designated ASA/CD Provider"
W !?3,"5) Clinic",?40,"11) Designated Primary Care Provider"
K DIR S DIR(0)="L^0:11",DIR("A")="Which items should be tallied",DIR("B")="" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
I Y="" G DATES
S AMHRTALL=Y
S A=Y,C="" F I=1:1 S C=$P(A,",",I) Q:C="" S AMHRTALL(C)=""
EXCL ;
S AMHREXPC=""
W !!,"Would you like to include Suicide Risk Assessments documented in the PCC"
S DIR(0)="Y",DIR("A")="clinical database",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S AMHREXPC=Y
LIST ;
S AMHRLIST=""
W !
S DIR(0)="Y",DIR("A")="Would you like to include a list of patients screened",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S AMHRLIST=Y
I 'AMHRLIST G DEMO
LIST1 ;
S AMHRSORT=""
W !
S DIR(0)="S^H:Health Record Number;N:Patient Name;P:Provider who screened;C:Clinic;R:Result of Assessment;D:Date Screened;A:Age of Patient at Screening;G:Gender of Patient;T:Terminal Digit HRN"
S DIR("A")="How would you like the list to be sorted",DIR("B")="H"
KILL DA D ^DIR KILL DIR
I $D(DIRUT) G LIST
S AMHRSORT=Y
DP ;
S AMHRDP=""
W !
S DIR(0)="Y",DIR("A")="Display the Patient's Designated Providers on the list",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G LIST
S AMHRDP=Y
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G LIST
ZIS ;CALL TO XBDBQUE
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) G XIT
I $G(Y)="B" D BROWSE,XIT Q
S XBRP="PRINT^AMHRSR1P",XBRC="PROC^AMHRSR1",XBRX="XIT^AMHRSR1",XBNS="AMH"
D ^XBDBQUE
D XIT
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""^AMHRSR1P"")"
S XBNS="AMH",XBRC="PROC^AMHRSR1",XBRX="XIT^AMHRSR1",XBIOP=0 D ^XBDBQUE
Q
XIT ;
D EN^XBVK("AMHR")
D ^XBFMK
Q
PROC ;
S AMHRCNT=0
S AMHRH=$H,AMHRJ=$J
K ^XTMP("AMHRSR1",AMHRJ,AMHRH)
D XTMP^AMHUTIL("AMHRSR1","SUICIDE RISK ASSESSMENT REPORT")
;now go through BH
S AMHRSD=$$FMADD^XLFDT(AMHRBD,-1),AMHRSD=AMHRSD_".9999"
F S AMHRSD=$O(^AMHREC("B",AMHRSD)) Q:AMHRSD'=+AMHRSD!($P(AMHRSD,".")>AMHRED) D
.S AMHRBIEN=0 F S AMHRBIEN=$O(^AMHREC("B",AMHRSD,AMHRBIEN)) Q:AMHRBIEN'=+AMHRBIEN D
..S AMHRDATE=$P(AMHRSD,".")
..Q:'$D(^AMHREC(AMHRBIEN,0))
..Q:$P($G(^AMHREC(AMHRBIEN,14)),U,7)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHRBIEN)
..Q:AMHRDATE>AMHRED
..Q:AMHRDATE<AMHRBD
..S DFN=$P(^AMHREC(AMHRBIEN,0),U,8)
..Q:DFN=""
..Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
..;S X=$O(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,0))
..;I X]"",X<AMHRDATE K ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,X)
..S AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1407) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
..S ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)="BH"_U_$$BHPPNAME(AMHRBIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9002011,AMHRBIEN,1901)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRBIEN
..S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,9)=$$VAL^XBDIQ1(9002011,AMHRBIEN,.25)
..S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,15)=AMHRBIEN
..S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,16)=$S($P($G(^AMHREC(AMHRBIEN,14)),U,8):$$VAL^XBDIQ1(9002011,AMHRBIEN,1408),1:"UNKNOWN")
..S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
..S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
..S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
..S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
;go through exam SRA, then through AUPNPREF for refusals
Q:'AMHREXPC
S AMHREIEN=0 F S AMHREIEN=$O(^AUPNVXAM("B",AMHREXC,AMHREIEN)) Q:AMHREIEN'=+AMHREIEN D
.Q:'$D(^AUPNVXAM(AMHREIEN,0))
.S DFN=$P(^AUPNVXAM(AMHREIEN,0),U,2)
.Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
.Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
.S AMHRVIEN=$P(^AUPNVXAM(AMHREIEN,0),U,3)
.Q:'AMHRVIEN
.Q:'$$ALLOWPCC^AMHUTIL(DUZ,AMHRVIEN) ;
.S AMHRDATE=$P($P($G(^AUPNVSIT(AMHRVIEN,0)),U),".")
.Q:AMHRDATE=""
.Q:AMHRDATE>AMHRED
.Q:AMHRDATE<AMHRBD
.Q:$D(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) ;already got one from BH on this date
.;S X=$O(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,0))
.;I X]"",X<AMHRDATE K ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,X)
.S AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
.S ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)="EX"_U_$$PPV(AMHRVIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9000010.13,AMHREIEN,81101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHREIEN
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,9)=$$VAL^XBDIQ1(9000010,AMHRVIEN,.08)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,15)=AMHRVIEN
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,16)=$$SPRV(AMHREIEN)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
;now go through refusals in pcc
S AMHRRIEN=0 F S AMHRRIEN=$O(^AUPNPREF(AMHRRIEN)) Q:AMHRRIEN'=+AMHRRIEN D
.Q:'$D(^AUPNPREF(AMHRRIEN,0))
.Q:$P(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
.Q:$P(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
.S AMHRDATE=$P(^AUPNPREF(AMHRRIEN,0),U,3)
.Q:AMHRDATE=""
.Q:AMHRDATE>AMHRED
.Q:AMHRDATE<AMHRBD
.S DFN=$P(^AUPNPREF(AMHRRIEN,0),U,2)
.Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
.Q:$D(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)) ;already got one from BH on this date
.;S X=$O(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,0))
.;I X]"",X<AMHRDATE K ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,X)
.S AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07) S:AMHRRES["REFUSED" AMHRRES="REFUSED SCREENING"
.S ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)="REF"_U_"UNKNOWN"_U_AMHRRES_U_$$VAL^XBDIQ1(9000022,AMHRRIEN,1101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRRIEN_U
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,16)=$$PRVREF(AMHRRIEN)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
.S $P(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
Q
;
BHPPNAME(R) ;EP primary provider internal # from 200
NEW %,%1
S %=0,%1="" F S %=$O(^AMHRPROV("AD",R,%)) Q:%'=+% I $P(^AMHRPROV(%,0),U,4)="P" S %1=$P(^AMHRPROV(%,0),U),%1=$P($G(^VA(200,%1,0)),U)
I %1]"" Q %1
Q "UNKNOWN"
SPRV(E) ;
I $P($G(^AUPNVXAM(E,12)),U,4) Q $$VAL^XBDIQ1(9000010.13,E,1204)
Q "UNKNOWN"
PRVREF(R) ;
I $P($G(^AUPNPREF(R,12)),U,4)]"" Q $$VAL^XBDIQ1(9000022,R,1204)
Q "UNKNOWN"
PPV(V) ;
NEW %
S %=$$PRIMPROV^APCLV(V)
I %]"" Q %
Q "UNKNOWN"
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")
;----------
AMHRSR1 ; IHS/CMI/LAB - list SUICIDE RISK ASSESSMENT 24 Aug 2009 6:21 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
+2 ;
+3 ;
INFORM ;
+1 WRITE !,$$CTR($$USR)
+2 WRITE !,$$LOC()
+3 WRITE !!,$$CTR("TALLY AND LISTING OF PATIENTS RECEIVING SUICIDE RISK ",80),!,$$CTR("ASSESSMENT, INCLUDING REFUSALS",80)
+4 WRITE !!,"This report will tally and optionally list all patients who have had "
+5 WRITE !,"a Suicide Risk Assessment or a refusal documented in the time frame"
+6 WRITE !,"specified by the user. Suicide Risk Assessment is defined as any of the"
+7 WRITE !,"following documented: "
+8 WRITE !?10,"- Suicide Risk Assessment (Exam code 43)"
+9 WRITE !?10,"- refusal of exam code 43"
+10 WRITE !,"This report will tally the patients by age, gender, screening exam result, "
+11 WRITE !,"provider (either exam provider, if available, or primary provider on the visit),"
+12 WRITE !,"clinic, date of screening, designated PCP, MH Provider, SS Provider and A/SA"
+13 WRITE !,"Provider."
+14 WRITE !," Notes: "
+15 WRITE !?10,"- the last screening/refusal for each patient is used. If a patient"
+16 WRITE !?10," was screened more than once in the time period, only the latest"
+17 WRITE !?10," is used in this report."
+18 WRITE !?10,"- this report will optionally, look at both PCC and the Behavioral"
+19 WRITE !?10," Health databases for evidence of screening/refusal"
+20 WRITE !?10,"- this is a tally of Patients, not visits or screenings"
+21 WRITE !
+22 DO PAUSE^AMHLEA
+23 DO DBHUSR^AMHUTIL
+24 DO XIT
+25 SET AMHREXC=$ORDER(^AUTTEXAM("C",43,0))
+26 IF 'AMHREXC
WRITE !!,"Exam code 43 is missing from the EXAM table. Cannot run report.",!
HANG 3
DO XIT
QUIT
+27 ;
DATES KILL AMHRED,AMHRBD
+1 WRITE !,"Please enter the date range during which the screening was done.",!,"To get all screenings ever put in a long date range like 01/01/1980 ",!,"to the present date.",!
+2 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date for Screening"
+3 DO ^DIR
IF Y<1
QUIT
SET AMHRBD=Y
+4 KILL DIR
SET DIR(0)="DO^:DT:EXP"
SET DIR("A")="Enter Ending Date for Screening"
+5 DO ^DIR
IF Y<1
QUIT
SET AMHRED=Y
+6 ;
+7 IF AMHRED<AMHRBD
Begin DoDot:1
+8 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO DATES
+9 ;
TALLY ;which items to tally
+1 KILL AMHRTALL
+2 WRITE !!,"Please select which items you wish to tally on this report:",!
+3 WRITE !?3,"0) Do not include any Tallies",?40,"6) Date of Screening"
+4 WRITE !?3,"1) Result of Assessment",?40,"7) Primary Provider on Visit"
+5 WRITE !?3,"2) Gender",?40,"8) Designated MH Provider"
+6 WRITE !?3,"3) Age of Patient",?40,"9) Designated SS Provider"
+7 WRITE !?3,"4) Provider who Screened",?40,"10) Designated ASA/CD Provider"
+8 WRITE !?3,"5) Clinic",?40,"11) Designated Primary Care Provider"
+9 KILL DIR
SET DIR(0)="L^0:11"
SET DIR("A")="Which items should be tallied"
SET DIR("B")=""
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
GOTO DATES
+11 IF Y=""
GOTO DATES
+12 SET AMHRTALL=Y
+13 SET A=Y
SET C=""
FOR I=1:1
SET C=$PIECE(A,",",I)
IF C=""
QUIT
SET AMHRTALL(C)=""
EXCL ;
+1 SET AMHREXPC=""
+2 WRITE !!,"Would you like to include Suicide Risk Assessments documented in the PCC"
+3 SET DIR(0)="Y"
SET DIR("A")="clinical database"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DATES
+5 SET AMHREXPC=Y
LIST ;
+1 SET AMHRLIST=""
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")="Would you like to include a list of patients screened"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DATES
+5 SET AMHRLIST=Y
+6 IF 'AMHRLIST
GOTO DEMO
LIST1 ;
+1 SET AMHRSORT=""
+2 WRITE !
+3 SET DIR(0)="S^H:Health Record Number;N:Patient Name;P:Provider who screened;C:Clinic;R:Result of Assessment;D:Date Screened;A:Age of Patient at Screening;G:Gender of Patient;T:Terminal Digit HRN"
+4 SET DIR("A")="How would you like the list to be sorted"
SET DIR("B")="H"
+5 KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
GOTO LIST
+7 SET AMHRSORT=Y
DP ;
+1 SET AMHRDP=""
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("A")="Display the Patient's Designated Providers on the list"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO LIST
+5 SET AMHRDP=Y
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO LIST
ZIS ;CALL TO XBDBQUE
+1 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
+2 IF $DATA(DIRUT)
GOTO XIT
+3 IF $GET(Y)="B"
DO BROWSE
DO XIT
QUIT
+4 SET XBRP="PRINT^AMHRSR1P"
SET XBRC="PROC^AMHRSR1"
SET XBRX="XIT^AMHRSR1"
SET XBNS="AMH"
+5 DO ^XBDBQUE
+6 DO XIT
+7 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""^AMHRSR1P"")"
+2 SET XBNS="AMH"
SET XBRC="PROC^AMHRSR1"
SET XBRX="XIT^AMHRSR1"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
XIT ;
+1 DO EN^XBVK("AMHR")
+2 DO ^XBFMK
+3 QUIT
PROC ;
+1 SET AMHRCNT=0
+2 SET AMHRH=$HOROLOG
SET AMHRJ=$JOB
+3 KILL ^XTMP("AMHRSR1",AMHRJ,AMHRH)
+4 DO XTMP^AMHUTIL("AMHRSR1","SUICIDE RISK ASSESSMENT REPORT")
+5 ;now go through BH
+6 SET AMHRSD=$$FMADD^XLFDT(AMHRBD,-1)
SET AMHRSD=AMHRSD_".9999"
+7 FOR
SET AMHRSD=$ORDER(^AMHREC("B",AMHRSD))
IF AMHRSD'=+AMHRSD!($PIECE(AMHRSD,".")>AMHRED)
QUIT
Begin DoDot:1
+8 SET AMHRBIEN=0
FOR
SET AMHRBIEN=$ORDER(^AMHREC("B",AMHRSD,AMHRBIEN))
IF AMHRBIEN'=+AMHRBIEN
QUIT
Begin DoDot:2
+9 SET AMHRDATE=$PIECE(AMHRSD,".")
+10 IF '$DATA(^AMHREC(AMHRBIEN,0))
QUIT
+11 IF $PIECE($GET(^AMHREC(AMHRBIEN,14)),U,7)=""
QUIT
+12 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHRBIEN)
QUIT
+13 IF AMHRDATE>AMHRED
QUIT
+14 IF AMHRDATE<AMHRBD
QUIT
+15 SET DFN=$PIECE(^AMHREC(AMHRBIEN,0),U,8)
+16 IF DFN=""
QUIT
+17 IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))
QUIT
+18 ;S X=$O(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,0))
+19 ;I X]"",X<AMHRDATE K ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,X)
+20 SET AMHRRES=$$VAL^XBDIQ1(9002011,AMHRBIEN,1407)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+21 SET ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)="BH"_U_$$BHPPNAME(AMHRBIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9002011,AMHRBIEN,1901)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRBIEN
+22 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,9)=$$VAL^XBDIQ1(9002011,AMHRBIEN,.25)
+23 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,15)=AMHRBIEN
+24 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,16)=$SELECT($PIECE($GET(^AMHREC(AMHRBIEN,14)),U,8):$$VAL^XBDIQ1(9002011,AMHRBIEN,1408),1:"UNKNOWN")
+25 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+26 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
+27 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
+28 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
End DoDot:2
End DoDot:1
+29 ;go through exam SRA, then through AUPNPREF for refusals
+30 IF 'AMHREXPC
QUIT
+31 SET AMHREIEN=0
FOR
SET AMHREIEN=$ORDER(^AUPNVXAM("B",AMHREXC,AMHREIEN))
IF AMHREIEN'=+AMHREIEN
QUIT
Begin DoDot:1
+32 IF '$DATA(^AUPNVXAM(AMHREIEN,0))
QUIT
+33 SET DFN=$PIECE(^AUPNVXAM(AMHREIEN,0),U,2)
+34 IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
QUIT
+35 IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))
QUIT
+36 SET AMHRVIEN=$PIECE(^AUPNVXAM(AMHREIEN,0),U,3)
+37 IF 'AMHRVIEN
QUIT
+38 ;
IF '$$ALLOWPCC^AMHUTIL(DUZ,AMHRVIEN)
QUIT
+39 SET AMHRDATE=$PIECE($PIECE($GET(^AUPNVSIT(AMHRVIEN,0)),U),".")
+40 IF AMHRDATE=""
QUIT
+41 IF AMHRDATE>AMHRED
QUIT
+42 IF AMHRDATE<AMHRBD
QUIT
+43 ;already got one from BH on this date
IF $DATA(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE))
QUIT
+44 ;S X=$O(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,0))
+45 ;I X]"",X<AMHRDATE K ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,X)
+46 SET AMHRRES=$$VAL^XBDIQ1(9000010.13,AMHREIEN,.04)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+47 SET ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)="EX"_U_$$PPV(AMHRVIEN)_U_AMHRRES_U_$$VAL^XBDIQ1(9000010.13,AMHREIEN,81101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHREIEN
+48 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,9)=$$VAL^XBDIQ1(9000010,AMHRVIEN,.08)
+49 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,15)=AMHRVIEN
+50 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,16)=$$SPRV(AMHREIEN)
+51 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+52 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
+53 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
+54 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
End DoDot:1
+55 ;now go through refusals in pcc
+56 SET AMHRRIEN=0
FOR
SET AMHRRIEN=$ORDER(^AUPNPREF(AMHRRIEN))
IF AMHRRIEN'=+AMHRRIEN
QUIT
Begin DoDot:1
+57 IF '$DATA(^AUPNPREF(AMHRRIEN,0))
QUIT
+58 IF $PIECE(^AUPNPREF(AMHRRIEN,0),U,5)'=9999999.15
QUIT
+59 IF $PIECE(^AUPNPREF(AMHRRIEN,0),U,6)'=AMHREXC
QUIT
+60 SET AMHRDATE=$PIECE(^AUPNPREF(AMHRRIEN,0),U,3)
+61 IF AMHRDATE=""
QUIT
+62 IF AMHRDATE>AMHRED
QUIT
+63 IF AMHRDATE<AMHRBD
QUIT
+64 SET DFN=$PIECE(^AUPNPREF(AMHRRIEN,0),U,2)
+65 IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
QUIT
+66 ;already got one from BH on this date
IF $DATA(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE))
QUIT
+67 ;S X=$O(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,0))
+68 ;I X]"",X<AMHRDATE K ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,X)
+69 SET AMHRRES=$$VAL^XBDIQ1(9000022,AMHRRIEN,.07)
IF AMHRRES["REFUSED"
SET AMHRRES="REFUSED SCREENING"
+70 SET ^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE)="REF"_U_"UNKNOWN"_U_AMHRRES_U_$$VAL^XBDIQ1(9000022,AMHRRIEN,1101)_U_$$AGE^AUPNPAT(DFN,AMHRDATE)_U_$$VAL^XBDIQ1(2,DFN,.02)_U_AMHRDATE_U_AMHRRIEN_U
+71 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,16)=$$PRVREF(AMHRRIEN)
+72 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,17)=$$VAL^XBDIQ1(9000001,DFN,.14)
+73 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,18)=$$VAL^XBDIQ1(9002011.55,DFN,.02)
+74 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,19)=$$VAL^XBDIQ1(9002011.55,DFN,.03)
+75 SET $PIECE(^XTMP("AMHRSR1",AMHRJ,AMHRH,"PTS",DFN,AMHRDATE),U,20)=$$VAL^XBDIQ1(9002011.55,DFN,.04)
End DoDot:1
+76 QUIT
+77 ;
BHPPNAME(R) ;EP primary provider internal # from 200
+1 NEW %,%1
+2 SET %=0
SET %1=""
FOR
SET %=$ORDER(^AMHRPROV("AD",R,%))
IF %'=+%
QUIT
IF $PIECE(^AMHRPROV(%,0),U,4)="P"
SET %1=$PIECE(^AMHRPROV(%,0),U)
SET %1=$PIECE($GET(^VA(200,%1,0)),U)
+3 IF %1]""
QUIT %1
+4 QUIT "UNKNOWN"
SPRV(E) ;
+1 IF $PIECE($GET(^AUPNVXAM(E,12)),U,4)
QUIT $$VAL^XBDIQ1(9000010.13,E,1204)
+2 QUIT "UNKNOWN"
PRVREF(R) ;
+1 IF $PIECE($GET(^AUPNPREF(R,12)),U,4)]""
QUIT $$VAL^XBDIQ1(9000022,R,1204)
+2 QUIT "UNKNOWN"
PPV(V) ;
+1 NEW %
+2 SET %=$$PRIMPROV^APCLV(V)
+3 IF %]""
QUIT %
+4 QUIT "UNKNOWN"
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 ;----------
