AMHRL1.m

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