AMHRPS1.m

AMHRPS1 ; IHS/CMI/LAB - PROCESS REPORT ;

 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 ;

 ;

 ;

 ;

START ;

 D XTMP^AMHUTIL("AMHRPS","BH - ABUSE/SUICIDE REPORT")

 S (AMHBT,AMHBTH)=$H,AMHJOB=$J

 S AMHRNN=AMHRBIN,AMHRA="" F I=1:1 S AMHRX=$P(AMHRNN,";",I) Q:AMHRX=""  D SETA

 S AMHRDOBS=AMHRA

 D DATE,XIT

 Q

 ;

DATE ; Run by encounter 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 D1

 Q

 ;

XIT ;

 S AMHET=$H

 D EOJ

 Q

EOJ ;

 Q

D1 ;

 S (AMHR,AMHRCNT)=0 F  S AMHR=$O(^AMHREC("B",AMHODAT,AMHR)) Q:AMHR'=+AMHR  I $D(^AMHREC(AMHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S AMHR0=^(0) D PROC

 Q

PROC ;

 S DFN=$P(AMHR0,U,8) Q:DFN=""  ;do not use if no patient

 Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)

 Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))

 Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHR)

 Q:'$D(^AMHRPRO("AD",AMHR))  ;quit if no problems entered

 Q:$D(^XTMP("AMHRPS",AMHJOB,AMHBTH,"PATIENTS",DFN))  ;quit if already counted this patient

 ;find pov

 S (AMHFOUND,X)=0,AMHSORT="" F  S X=$O(^AMHRPRO("AD",AMHR,X)) Q:X'=+X!(AMHFOUND)  S P=$P(^AMHRPRO(X,0),U),P=$P(^AMHPROB(P,0),U) I $D(AMHPROB(P)) S AMHFOUND=1,AMHSORT=P

 Q:'AMHFOUND  ; quit if not visit for problem

SETTMP ;

 S AMHRAGE="" D GETAGE

 Q:'AMHRAGE

 Q:AMHRSEX=""

 S ^XTMP("AMHRPS",AMHJOB,AMHBTH,"PATIENTS",DFN)=""

 S ^(AMHRAGE)=$S($D(^XTMP("AMHRPS",AMHJOB,AMHBTH,"AGE",AMHRSEX,AMHSORT,AMHRAGE)):^(AMHRAGE)+1,1:1)

 S ^(AMHRAGE)=$S($D(^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL",AMHRSEX,AMHRAGE)):^(AMHRAGE)+1,1:1)

 S ^(AMHSORT)=$S($D(^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL SORT",AMHRSEX,AMHSORT)):^(AMHSORT)+1,1:1)

 S ^(AMHRAGE)=$S($D(^XTMP("AMHRPS",AMHJOB,AMHBTH,"AGE","B",AMHSORT,AMHRAGE)):^(AMHRAGE)+1,1:1)

 S ^(AMHRAGE)=$S($D(^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL","B",AMHRAGE)):^(AMHRAGE)+1,1:1)

 S ^(AMHSORT)=$S($D(^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL SORT","B",AMHSORT)):^(AMHSORT)+1,1:1)

 Q

GETAGE ;

 S AMHRDOB=$P(^DPT($P(AMHR0,U,8),0),U,3) Q:AMHRDOB=""

 S AMHRSEX=$P(^DPT($P(AMHR0,U,8),0),U,2)

ATT ;

 F I=1:1 S AMHRNN=$P(AMHRA,";",I) Q:AMHRNN=""  S AMHRX=$P(AMHRNN,"-"),AMHRY=$P(AMHRNN,"-",2) I AMHRDOB'<AMHRX,AMHRDOB'>AMHRY  S AMHRAGE=I Q

 Q

 ;

 ;

SETA ;

 S AMHRY=$P(AMHRX,"-"),AMHRZ=$P(AMHRX,"-",2)

 I AMHRA]"" S AMHRA=AMHRA_";"

 S AMHRA=AMHRA_(DT+1-(10000*(AMHRZ+1)))_"-"_(DT-(AMHRY*10000))

 S ^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL","AGE",I)=0

 Q

AMHRPS1   ; IHS/CMI/LAB - PROCESS REPORT ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 +2       ;

 +3       ;

 +4       ;

 +5       ;

START     ;

 +1        DO XTMP^AMHUTIL("AMHRPS","BH - ABUSE/SUICIDE REPORT")

 +2        SET (AMHBT,AMHBTH)=$HOROLOG

           SET AMHJOB=$JOB

 +3        SET AMHRNN=AMHRBIN

           SET AMHRA=""

           FOR I=1:1

               SET AMHRX=$PIECE(AMHRNN,";",I)

               IF AMHRX=""

                   QUIT 

               DO SETA

 +4        SET AMHRDOBS=AMHRA

 +5        DO DATE

           DO XIT

 +6        QUIT 

 +7       ;

DATE      ; Run by encounter 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 D1

 +3        QUIT 

 +4       ;

XIT       ;

 +1        SET AMHET=$HOROLOG

 +2        DO EOJ

 +3        QUIT 

EOJ       ;

 +1        QUIT 

D1        ;

 +1        SET (AMHR,AMHRCNT)=0

           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)]""

                           SET AMHR0=^(0)

                           DO PROC

 +2        QUIT 

PROC      ;

 +1       ;do not use if no patient

           SET DFN=$PIECE(AMHR0,U,8)

           IF DFN=""

               QUIT 

 +2        IF '$$ALLOWP^AMHUTIL(DUZ,DFN)

               QUIT 

 +3        IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))

               QUIT 

 +4        IF '$$ALLOWVI^AMHUTIL(DUZ,AMHR)

               QUIT 

 +5       ;quit if no problems entered

           IF '$DATA(^AMHRPRO("AD",AMHR))

               QUIT 

 +6       ;quit if already counted this patient

           IF $DATA(^XTMP("AMHRPS",AMHJOB,AMHBTH,"PATIENTS",DFN))

               QUIT 

 +7       ;find pov

 +8        SET (AMHFOUND,X)=0

           SET AMHSORT=""

           FOR 

               SET X=$ORDER(^AMHRPRO("AD",AMHR,X))

               IF X'=+X!(AMHFOUND)

                   QUIT 

               SET P=$PIECE(^AMHRPRO(X,0),U)

               SET P=$PIECE(^AMHPROB(P,0),U)

               IF $DATA(AMHPROB(P))

                   SET AMHFOUND=1

                   SET AMHSORT=P

 +9       ; quit if not visit for problem

           IF 'AMHFOUND

               QUIT 

SETTMP    ;

 +1        SET AMHRAGE=""

           DO GETAGE

 +2        IF 'AMHRAGE

               QUIT 

 +3        IF AMHRSEX=""

               QUIT 

 +4        SET ^XTMP("AMHRPS",AMHJOB,AMHBTH,"PATIENTS",DFN)=""

 +5        SET ^(AMHRAGE)=$SELECT($DATA(^XTMP("AMHRPS",AMHJOB,AMHBTH,"AGE",AMHRSEX,AMHSORT,AMHRAGE)):^(AMHRAGE)+1,1:1)

 +6        SET ^(AMHRAGE)=$SELECT($DATA(^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL",AMHRSEX,AMHRAGE)):^(AMHRAGE)+1,1:1)

 +7        SET ^(AMHSORT)=$SELECT($DATA(^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL SORT",AMHRSEX,AMHSORT)):^(AMHSORT)+1,1:1)

 +8        SET ^(AMHRAGE)=$SELECT($DATA(^XTMP("AMHRPS",AMHJOB,AMHBTH,"AGE","B",AMHSORT,AMHRAGE)):^(AMHRAGE)+1,1:1)

 +9        SET ^(AMHRAGE)=$SELECT($DATA(^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL","B",AMHRAGE)):^(AMHRAGE)+1,1:1)

 +10       SET ^(AMHSORT)=$SELECT($DATA(^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL SORT","B",AMHSORT)):^(AMHSORT)+1,1:1)

 +11       QUIT 

GETAGE    ;

 +1        SET AMHRDOB=$PIECE(^DPT($PIECE(AMHR0,U,8),0),U,3)

           IF AMHRDOB=""

               QUIT 

 +2        SET AMHRSEX=$PIECE(^DPT($PIECE(AMHR0,U,8),0),U,2)

ATT       ;

 +1        FOR I=1:1

               SET AMHRNN=$PIECE(AMHRA,";",I)

               IF AMHRNN=""

                   QUIT 

               SET AMHRX=$PIECE(AMHRNN,"-")

               SET AMHRY=$PIECE(AMHRNN,"-",2)

               IF AMHRDOB'<AMHRX

                   IF AMHRDOB'>AMHRY

                       SET AMHRAGE=I

                       QUIT 

 +2        QUIT 

 +3       ;

 +4       ;

SETA      ;

 +1        SET AMHRY=$PIECE(AMHRX,"-")

           SET AMHRZ=$PIECE(AMHRX,"-",2)

 +2        IF AMHRA]""

               SET AMHRA=AMHRA_";"

 +3        SET AMHRA=AMHRA_(DT+1-(10000*(AMHRZ+1)))_"-"_(DT-(AMHRY*10000))

 +4        SET ^XTMP("AMHRPS",AMHJOB,AMHBTH,"TOTAL","AGE",I)=0

 +5        QUIT