AMHLEDV1.m

AMHLEDV1 ; IHS/CMI/LAB - ;

 ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18

 ;

 ;

 ;

GATHER ;EP

 K AMHQUIT,^TMP("AMHPATV",$J) S AMHRCNT=0

 D GETRECS

EOJ K AMHQUIT,AMHPG,AMHREC,AMHV,AMHP,Y,AMHPREC,AMHHRN,X,Y,Z,%,AMHX,AMHSD,AMHODAT,AMHX,I,L,V,AMHRS,AMHPATV

 Q

GETRECS ;

 S (AMHRCNT,AMHV)=0 F  S AMHV=$O(AMHPATV(AMHV)) Q:AMHV=""  D

 .S AMHRCNT=AMHRCNT+1,AMHRS=AMHRCNT,^TMP("AMHPATV",$J,"IDX",AMHRCNT,AMHRCNT)=AMHV,AMHREC=^AMHREC(AMHV,0) D REC S ^TMP("AMHPATV",$J,AMHRCNT,0)=AMHX

 .Q

 Q

 ;

REC ;

 S AMHX=$J(AMHRS,3)_" " S X=$$PPINI^AMHUTIL(AMHV),X=$$LBLK(X,3) S AMHX=AMHX_X_" "_$$FMTE^XLFDT($P(AMHREC,U)),AMHX=$$RBLK(AMHX,28)

 S X=$E($$VAL^XBDIQ1(9002011,AMHV,.07),1,6),X=$$RBLK(X,8)

 S AMHX=AMHX_X

 S X=$P(AMHREC,U,4) I X]"" S X=$E($P(^DIC(4,X,0),U),1,8),X=$$RBLK(X,10)

 S AMHX=AMHX_X

 S AMHX=AMHX_$$VAL^XBDIQ1(9002011,AMHV,.06)

 S AMHX=$$RBLK(AMHX,51)

 S AMHP=$O(^AMHRPRO("AD",AMHV,0)) I AMHP="" S X="   <No Problems recorded.>",X=$$RBLK(X,29),AMHX=AMHX_X Q

 D GETPROB

 Q

GETPROB ;

 S AMHP=$O(^AMHRPRO("AD",AMHV,0)),AMHPREC=^AMHRPRO(AMHP,0)

 S X=$P(^AMHPROB($P(AMHPREC,U),0),U),X=$$LBLK(X,6)_" "

 S X=X_$$GET1^DIQ(9002011.01,AMHP,.04)

 S AMHX=AMHX_X

 Q

RBLK(V,L) ;left blank fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "

 Q V

LBLK(V,L) ;left blank fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V

 Q V

AMHLEDV1  ; IHS/CMI/LAB - ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18

 +2       ;

 +3       ;

 +4       ;

GATHER    ;EP

 +1        KILL AMHQUIT,^TMP("AMHPATV",$JOB)

           SET AMHRCNT=0

 +2        DO GETRECS

EOJ        KILL AMHQUIT,AMHPG,AMHREC,AMHV,AMHP,Y,AMHPREC,AMHHRN,X,Y,Z,%,AMHX,AMHSD,AMHODAT,AMHX,I,L,V,AMHRS,AMHPATV

 +1        QUIT 

GETRECS   ;

 +1        SET (AMHRCNT,AMHV)=0

           FOR 

               SET AMHV=$ORDER(AMHPATV(AMHV))

               IF AMHV=""

                   QUIT 

               Begin DoDot:1

 +2                SET AMHRCNT=AMHRCNT+1

                   SET AMHRS=AMHRCNT

                   SET ^TMP("AMHPATV",$JOB,"IDX",AMHRCNT,AMHRCNT)=AMHV

                   SET AMHREC=^AMHREC(AMHV,0)

                   DO REC

                   SET ^TMP("AMHPATV",$JOB,AMHRCNT,0)=AMHX

 +3                QUIT 

               End DoDot:1

 +4        QUIT 

 +5       ;

REC       ;

 +1        SET AMHX=$JUSTIFY(AMHRS,3)_" "

           SET X=$$PPINI^AMHUTIL(AMHV)

           SET X=$$LBLK(X,3)

           SET AMHX=AMHX_X_" "_$$FMTE^XLFDT($PIECE(AMHREC,U))

           SET AMHX=$$RBLK(AMHX,28)

 +2        SET X=$EXTRACT($$VAL^XBDIQ1(9002011,AMHV,.07),1,6)

           SET X=$$RBLK(X,8)

 +3        SET AMHX=AMHX_X

 +4        SET X=$PIECE(AMHREC,U,4)

           IF X]""

               SET X=$EXTRACT($PIECE(^DIC(4,X,0),U),1,8)

               SET X=$$RBLK(X,10)

 +5        SET AMHX=AMHX_X

 +6        SET AMHX=AMHX_$$VAL^XBDIQ1(9002011,AMHV,.06)

 +7        SET AMHX=$$RBLK(AMHX,51)

 +8        SET AMHP=$ORDER(^AMHRPRO("AD",AMHV,0))

           IF AMHP=""

               SET X="   <No Problems recorded.>"

               SET X=$$RBLK(X,29)

               SET AMHX=AMHX_X

               QUIT 

 +9        DO GETPROB

 +10       QUIT 

GETPROB   ;

 +1        SET AMHP=$ORDER(^AMHRPRO("AD",AMHV,0))

           SET AMHPREC=^AMHRPRO(AMHP,0)

 +2        SET X=$PIECE(^AMHPROB($PIECE(AMHPREC,U),0),U)

           SET X=$$LBLK(X,6)_" "

 +3        SET X=X_$$GET1^DIQ(9002011.01,AMHP,.04)

 +4        SET AMHX=AMHX_X

 +5        QUIT 

RBLK(V,L) ;left blank fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=V_" "

 +3        QUIT V

LBLK(V,L) ;left blank fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V=" "_V

 +3        QUIT V