AMHRL1 ; IHS/CMI/LAB - TUCSON-OHPRD/LAB - PROCESS BH RECORD LIST ;
;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
;
;
;
START ;
S (AMHBT,AMHBTH)=$H,AMHJOB=$J,AMHRCNT=0
D XTMP^AMHUTIL("AMHRL","BH - GENERAL RETRIEVAL")
S AMHPROC=AMHPTVS_AMHTYPE
I $D(AMHRDTR),AMHPTVS="P"!(AMHPTVS="S") S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X
D @AMHPROC,END
Q
;
SSU ;suicide
S AMHR=0 F S AMHR=$O(^AMHPSUIC(AMHR)) Q:AMHR'=+AMHR D
.S AMHR0=^AMHPSUIC(AMHR,0),DFN=$P(AMHR0,U,4)
.Q:$P(^AMHPSUIC(AMHR,0),U,6)=""
.Q:$P(^AMHPSUIC(AMHR,0),U,6)<AMHBD
.Q:$P(^AMHPSUIC(AMHR,0),U,6)>AMHED
.D PROC
Q
VS ;run by search template
S AMHR=0 F S AMHR=$O(^DIBT(AMHSEAT,1,AMHR)) Q:AMHR'=+AMHR I $D(^AMHREC(AMHR,0)) S AMHR0=^AMHREC(AMHR,0),DFN=$P(AMHR0,U,8) D PROC
Q
VD ; Run by visit date
S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X
S AMHODAT=AMHSD_".9999" F S AMHODAT=$O(^AMHREC("B",AMHODAT)) Q:AMHODAT=""!((AMHODAT\1)>AMHED) D V1
Q
;
PP ;
S AMHR=0 F S AMHR=$O(^DPT(AMHR)) Q:AMHR'=+AMHR I '$P(^DPT(AMHR,0),U,19) S DFN=AMHR D PROC
Q
;
PS ;
S AMHR=0 F S AMHR=$O(^DIBT(AMHSEAT,1,AMHR)) Q:AMHR'=+AMHR I $D(^DPT(AMHR,0)),'$P(^(0),U,19) S DFN=AMHR D PROC
Q
;
;
END ;
S AMHET=$H
Q
V1 ;
S AMHR="" F S AMHR=$O(^AMHREC("B",AMHODAT,AMHR)) Q:AMHR'=+AMHR I $D(^AMHREC(AMHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"",$P(^(0),U,4)]"" S AMHR0=^AMHREC(AMHR,0),DFN=$P(AMHR0,U,8) D PROC
Q
PROC ;
;I AMHPTVS="V" S AMHR0=^AMHREC(AMHR,0),DFN=$P(AMHR0,U,8)
;I AMHPTVS="P" S DFN=AMHR
I AMHPTVS="P",DFN="" Q
Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
I AMHPTVS="P",'$$ALLOWP^AMHUTIL(DUZ,DFN) Q
I AMHPTVS="V",'$$ALLOWVI^AMHUTIL(DUZ,AMHR) Q
D SCREENS
Q:$D(AMHSKIP)
K AMHSRT,AMHPRNT S AMHCRIT=AMHSORT,AMHX=0 X:$D(^AMHSORT(AMHSORT,5)) ^AMHSORT(AMHSORT,5) I '$D(AMHPRNT) D
. I AMHPTVS="S" S AMHPRNT="--"
. I AMHPTVS="V" S Y=$P($P(AMHR0,U),".") D DD^%DT S AMHPRNT=Y Q
. S AMHPRNT=$P(^DPT(DFN,0),U)
. Q
S AMHSRT=AMHPRNT
D SUBPAT
I AMHPTVS="S" S ^XTMP("AMHRL",AMHJOB,AMHBTH,"DATA HITS",AMHSRT,AMHR)="",AMHRCNT=AMHRCNT+1 G P1
I '$D(AMHRDTR) S ^XTMP("AMHRL",AMHJOB,AMHBTH,"DATA HITS",AMHSRT,AMHR)="",AMHRCNT=AMHRCNT+1
I $D(AMHRDTR) S ^XTMP("AMHRL",AMHJOB,AMHBTH,"DATA HITS",AMHSRT,DFN)="",AMHRCNT=AMHRCNT+1
P1 Q:'$G(DFN)
Q:$D(^XTMP("AMHRL",AMHJOB,AMHBTH,"PATIENTS",DFN))
S ^XTMP("AMHRL",AMHJOB,AMHBTH,"PATIENTS",DFN)="",AMHPTCT=AMHPTCT+1
Q
SUBPAT ;tally # of patients by sort value on detailed/subtotal
Q:'$G(DFN)
Q:AMHCTYP="C"
Q:AMHCTYP="F"
Q:AMHCTYP="T"
S:$G(AMHSRT)="" AMHSRT="???"
Q:$D(^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PATIENT HIT",AMHSRT,DFN))
S:'$D(^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PAT COUNT",AMHSRT)) ^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PAT COUNT",AMHSRT)=0
S ^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PAT COUNT",AMHSRT)=^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PAT COUNT",AMHSRT)+1
Q:$D(^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PATIENT HIT",AMHSRT,DFN))
S ^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PATIENT HIT",AMHSRT,DFN)=""
Q
SCREENS ;
K AMHSKIP
S AMHI=0 F S AMHI=$O(^AMHTRPT(AMHRPT,11,AMHI)) Q:AMHI'=+AMHI!($D(AMHSKIP)) D
.I '$P(^AMHSORT(AMHI,0),U,8) D SINGLE Q
.D MULT
.Q
Q
SINGLE ;
K X,AMHSPEC S X="",AMHX=0
X:$D(^AMHSORT(AMHI,1)) ^(1)
I X="" S AMHSKIP="" Q
I '$D(AMHSPEC),'$D(^AMHTRPT(AMHRPT,11,AMHI,11,"B",X)) S AMHSKIP="" Q
Q
MULT ;
K AMHFOUN,AMHSKIP,AMHSPEC,X S AMHX=0,X=""
X:$D(^AMHSORT(AMHI,1)) ^(1)
I $O(X(""))="" S AMHSKIP="" Q
I '$D(AMHSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^AMHTRPT(AMHRPT,11,AMHI,11,"B",Y)) S AMHFOUN="" Q
I $D(AMHSPEC),$D(X) S AMHFOUN=1 Q
S:'$D(AMHFOUN) AMHSKIP=""
Q
XIT ;EP - CALLED FROM AMHRL
K AMHBD,AMHBDD,AMHED,AMHEDD,AMHSD,AMHSORT,AMHSORV,AMHTCW,AMHRPT,AMHLHDR,AMHDISP,%H,AMHET,AMHLINE,AMHPRNM,AMHPRNT,AMHSKIP,AMHTYPE,AMHSPAG,AMHEN1,AMHSEAT,AMHPTVS,AMHPROC,AMH,AMHCAND,AMHHDR,AMHHEAD,AMHJD
K AMHACE,AMHCTYP,AMHFLG,AMHG,AMHNAME,AMHNIFN,AMHSAVE,AMHTITL,AMHQUIT,AMHPCNT,AMHQFLG,AMHPTCT,AMHTL,AMHXREF,AMHSRTR,AMHSRTV,AMHGBD,AMHGBE,AMHGBS,AMHGDE,AMHGDB,AMHGDS
K C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH
XIT1 ;EP
K AMHANS,AMHBTH,AMHC,AMHCNT,AMHCRIT,AMHCUT,AMHD,AMHDISP,AMHDONE,AMHHIGH,AMHI,AMHJOB,AMHQMAN,AMHSEL,AMHTEXT,AMHRAR,AMHSKIP,AMHPRNT,AMHPRNM,AMHLINE,AMHRCNT,AMHDFET,AMHY,DFN,AMHQ
K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,AMHPACK,AMHEP1,AMHEP2,D,AMHLENG,AMHLHDR,AMHSAVE
Q
AMHRL1 ; IHS/CMI/LAB - TUCSON-OHPRD/LAB - PROCESS BH RECORD LIST ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
+2 ;
+3 ;
+4 ;
START ;
+1 SET (AMHBT,AMHBTH)=$HOROLOG
SET AMHJOB=$JOB
SET AMHRCNT=0
+2 DO XTMP^AMHUTIL("AMHRL","BH - GENERAL RETRIEVAL")
+3 SET AMHPROC=AMHPTVS_AMHTYPE
+4 IF $DATA(AMHRDTR)
IF AMHPTVS="P"!(AMHPTVS="S")
SET X1=AMHBD
SET X2=-1
DO C^%DTC
SET AMHSD=X
+5 DO @AMHPROC
DO END
+6 QUIT
+7 ;
SSU ;suicide
+1 SET AMHR=0
FOR
SET AMHR=$ORDER(^AMHPSUIC(AMHR))
IF AMHR'=+AMHR
QUIT
Begin DoDot:1
+2 SET AMHR0=^AMHPSUIC(AMHR,0)
SET DFN=$PIECE(AMHR0,U,4)
+3 IF $PIECE(^AMHPSUIC(AMHR,0),U,6)=""
QUIT
+4 IF $PIECE(^AMHPSUIC(AMHR,0),U,6)<AMHBD
QUIT
+5 IF $PIECE(^AMHPSUIC(AMHR,0),U,6)>AMHED
QUIT
+6 DO PROC
End DoDot:1
+7 QUIT
VS ;run by search template
+1 SET AMHR=0
FOR
SET AMHR=$ORDER(^DIBT(AMHSEAT,1,AMHR))
IF AMHR'=+AMHR
QUIT
IF $DATA(^AMHREC(AMHR,0))
SET AMHR0=^AMHREC(AMHR,0)
SET DFN=$PIECE(AMHR0,U,8)
DO PROC
+2 QUIT
VD ; Run by visit date
+1 SET X1=AMHBD
SET X2=-1
DO C^%DTC
SET AMHSD=X
+2 SET AMHODAT=AMHSD_".9999"
FOR
SET AMHODAT=$ORDER(^AMHREC("B",AMHODAT))
IF AMHODAT=""!((AMHODAT\1)>AMHED)
QUIT
DO V1
+3 QUIT
+4 ;
PP ;
+1 SET AMHR=0
FOR
SET AMHR=$ORDER(^DPT(AMHR))
IF AMHR'=+AMHR
QUIT
IF '$PIECE(^DPT(AMHR,0),U,19)
SET DFN=AMHR
DO PROC
+2 QUIT
+3 ;
PS ;
+1 SET AMHR=0
FOR
SET AMHR=$ORDER(^DIBT(AMHSEAT,1,AMHR))
IF AMHR'=+AMHR
QUIT
IF $DATA(^DPT(AMHR,0))
IF '$PIECE(^(0),U,19)
SET DFN=AMHR
DO PROC
+2 QUIT
+3 ;
+4 ;
END ;
+1 SET AMHET=$HOROLOG
+2 QUIT
V1 ;
+1 SET AMHR=""
FOR
SET AMHR=$ORDER(^AMHREC("B",AMHODAT,AMHR))
IF AMHR'=+AMHR
QUIT
IF $DATA(^AMHREC(AMHR,0))
IF $PIECE(^(0),U,2)]""
IF $PIECE(^(0),U,3)]""
IF $PIECE(^(0),U,4)]""
SET AMHR0=^AMHREC(AMHR,0)
SET DFN=$PIECE(AMHR0,U,8)
DO PROC
+2 QUIT
PROC ;
+1 ;I AMHPTVS="V" S AMHR0=^AMHREC(AMHR,0),DFN=$P(AMHR0,U,8)
+2 ;I AMHPTVS="P" S DFN=AMHR
+3 IF AMHPTVS="P"
IF DFN=""
QUIT
+4 IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))
QUIT
+5 IF AMHPTVS="P"
IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
QUIT
+6 IF AMHPTVS="V"
IF '$$ALLOWVI^AMHUTIL(DUZ,AMHR)
QUIT
+7 DO SCREENS
+8 IF $DATA(AMHSKIP)
QUIT
+9 KILL AMHSRT,AMHPRNT
SET AMHCRIT=AMHSORT
SET AMHX=0
IF $DATA(^AMHSORT(AMHSORT,5))
XECUTE ^AMHSORT(AMHSORT,5)
IF '$DATA(AMHPRNT)
Begin DoDot:1
+10 IF AMHPTVS="S"
SET AMHPRNT="--"
+11 IF AMHPTVS="V"
SET Y=$PIECE($PIECE(AMHR0,U),".")
DO DD^%DT
SET AMHPRNT=Y
QUIT
+12 SET AMHPRNT=$PIECE(^DPT(DFN,0),U)
+13 QUIT
End DoDot:1
+14 SET AMHSRT=AMHPRNT
+15 DO SUBPAT
+16 IF AMHPTVS="S"
SET ^XTMP("AMHRL",AMHJOB,AMHBTH,"DATA HITS",AMHSRT,AMHR)=""
SET AMHRCNT=AMHRCNT+1
GOTO P1
+17 IF '$DATA(AMHRDTR)
SET ^XTMP("AMHRL",AMHJOB,AMHBTH,"DATA HITS",AMHSRT,AMHR)=""
SET AMHRCNT=AMHRCNT+1
+18 IF $DATA(AMHRDTR)
SET ^XTMP("AMHRL",AMHJOB,AMHBTH,"DATA HITS",AMHSRT,DFN)=""
SET AMHRCNT=AMHRCNT+1
P1 IF '$GET(DFN)
QUIT
+1 IF $DATA(^XTMP("AMHRL",AMHJOB,AMHBTH,"PATIENTS",DFN))
QUIT
+2 SET ^XTMP("AMHRL",AMHJOB,AMHBTH,"PATIENTS",DFN)=""
SET AMHPTCT=AMHPTCT+1
+3 QUIT
SUBPAT ;tally # of patients by sort value on detailed/subtotal
+1 IF '$GET(DFN)
QUIT
+2 IF AMHCTYP="C"
QUIT
+3 IF AMHCTYP="F"
QUIT
+4 IF AMHCTYP="T"
QUIT
+5 IF $GET(AMHSRT)=""
SET AMHSRT="???"
+6 IF $DATA(^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PATIENT HIT",AMHSRT,DFN))
QUIT
+7 IF '$DATA(^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PAT COUNT",AMHSRT))
SET ^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PAT COUNT",AMHSRT)=0
+8 SET ^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PAT COUNT",AMHSRT)=^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PAT COUNT",AMHSRT)+1
+9 IF $DATA(^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PATIENT HIT",AMHSRT,DFN))
QUIT
+10 SET ^XTMP("AMHRL",AMHJOB,AMHBTH,"SUB PATIENT HIT",AMHSRT,DFN)=""
+11 QUIT
SCREENS ;
+1 KILL AMHSKIP
+2 SET AMHI=0
FOR
SET AMHI=$ORDER(^AMHTRPT(AMHRPT,11,AMHI))
IF AMHI'=+AMHI!($DATA(AMHSKIP))
QUIT
Begin DoDot:1
+3 IF '$PIECE(^AMHSORT(AMHI,0),U,8)
DO SINGLE
QUIT
+4 DO MULT
+5 QUIT
End DoDot:1
+6 QUIT
SINGLE ;
+1 KILL X,AMHSPEC
SET X=""
SET AMHX=0
+2 IF $DATA(^AMHSORT(AMHI,1))
XECUTE ^(1)
+3 IF X=""
SET AMHSKIP=""
QUIT
+4 IF '$DATA(AMHSPEC)
IF '$DATA(^AMHTRPT(AMHRPT,11,AMHI,11,"B",X))
SET AMHSKIP=""
QUIT
+5 QUIT
MULT ;
+1 KILL AMHFOUN,AMHSKIP,AMHSPEC,X
SET AMHX=0
SET X=""
+2 IF $DATA(^AMHSORT(AMHI,1))
XECUTE ^(1)
+3 IF $ORDER(X(""))=""
SET AMHSKIP=""
QUIT
+4 IF '$DATA(AMHSPEC)
SET Y=""
FOR
SET Y=$ORDER(X(Y))
IF Y=""
QUIT
IF $DATA(^AMHTRPT(AMHRPT,11,AMHI,11,"B",Y))
SET AMHFOUN=""
QUIT
+5 IF $DATA(AMHSPEC)
IF $DATA(X)
SET AMHFOUN=1
QUIT
+6 IF '$DATA(AMHFOUN)
SET AMHSKIP=""
+7 QUIT
XIT ;EP - CALLED FROM AMHRL
+1 KILL AMHBD,AMHBDD,AMHED,AMHEDD,AMHSD,AMHSORT,AMHSORV,AMHTCW,AMHRPT,AMHLHDR,AMHDISP,%H,AMHET,AMHLINE,AMHPRNM,AMHPRNT,AMHSKIP,AMHTYPE,AMHSPAG,AMHEN1,AMHSEAT,AMHPTVS,AMHPROC,AMH,AMHCAND,AMHHDR,AMHHEAD,AMHJD
+2 KILL AMHACE,AMHCTYP,AMHFLG,AMHG,AMHNAME,AMHNIFN,AMHSAVE,AMHTITL,AMHQUIT,AMHPCNT,AMHQFLG,AMHPTCT,AMHTL,AMHXREF,AMHSRTR,AMHSRTV,AMHGBD,AMHGBE,AMHGBS,AMHGDE,AMHGDB,AMHGDS
+3 KILL C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH
XIT1 ;EP
+1 KILL AMHANS,AMHBTH,AMHC,AMHCNT,AMHCRIT,AMHCUT,AMHD,AMHDISP,AMHDONE,AMHHIGH,AMHI,AMHJOB,AMHQMAN,AMHSEL,AMHTEXT,AMHRAR,AMHSKIP,AMHPRNT,AMHPRNM,AMHLINE,AMHRCNT,AMHDFET,AMHY,DFN,AMHQ
+2 KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,AMHPACK,AMHEP1,AMHEP2,D,AMHLENG,AMHLHDR,AMHSAVE
+3 QUIT
