AMHLETP4 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;
GATHER ;gather up and display all problems/goals/methods
K ^TMP("AMHPTPP",$J)
NEW AMHA,AMHB,AMHC,X,Y,Z,AMHL
S (AMHA,AMHLINE,AMHRCNT)=0 F S AMHA=$O(^AMHPTPP("AD",AMHTP,AMHA)) Q:AMHA'=+AMHA S AMH0=^AMHPTPP(AMHA,0) D
.S AMHRCNT=$G(AMHRCNT)+1
.S X=AMHRCNT_") "_IORVON_"Problem: "_IORVOFF_IOINHI_$E($P(AMH0,U),1,44)_IOINORM,$E(X,60)="Status: "_$$VAL^XBDIQ1(9002011.62,AMHA,.12) D S S ^TMP("AMHPTPP",$J,"IDX",AMHRCNT,AMHLINE)=AMHA
.S Y=0 F S Y=$O(^AMHPTPP(AMHA,11,Y)) Q:Y'=+Y S X="",$E(X,5)=^AMHPTPP(AMHA,11,Y,0) D S
.S X=" Date Established: "_$$VAL^XBDIQ1(9002011.62,AMHA,.08),$E(X,42)="Established by: "_$E($$VAL^XBDIQ1(9002011.62,AMHA,.06),1,25) D S
.S X=" Date Last Modified: "_$$VAL^XBDIQ1(9002011.62,AMHA,.08),$E(X,42)="Modified by: "_$E($$VAL^XBDIQ1(9002011.62,AMHA,.06),1,25) D S
.Q
Q ;*** new format
WP ;EP - Entry point to print wp fields pass node in AMHNODE
;PASS FILE IN AMHFILE, ENTRY IN AMHDA
NEW AMHX,AMHPCNT
S AMHPCNT=0
K AMHPRNM
S AMHX=0 F S AMHX=$O(^AMHPTXP(AMHDA,AMHNODE,AMHX)) Q:AMHX'=+AMHX D
.S AMHPCNT=AMHPCNT+1
.S AMHPRNM(AMHPCNT)=^AMHPTXP(AMHDA,AMHNODE,AMHX,0)
.Q
Q
NWP ;EP
K ^UTILITY($J,"W")
S AMHX=0
S AMHG=$S($G(AMHG)]"":AMHG,1:^DIC(AMHFILE,0,"GL")),AMHG=AMHG_AMHDA_","_AMHNODE_",AMHX)"
S DIWL=$S($G(AMHCOL):AMHCOL,1:1),DIWR=70 F S AMHX=$O(@AMHG) Q:AMHX'=+AMHX D
.S Y=$P(AMHG,")")_",0)" S X=$TR(@Y,$C(10)) D ^DIWP
.Q
WPS ;EP
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S AMHPCNT=AMHPCNT+1,AMHPRNM(AMHPCNT)=^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),AMHNODE,AMHFILE,AMHDA,AMHG,AMHCOL
Q
S ;
S AMHLINE=AMHLINE+1
S ^TMP("AMHPTPP",$J,AMHLINE,0)=X
Q
EOP ;
W ! S DIR("A")="Press enter...",DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT="" Q
Q
AMHLETP4 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;
GATHER ;gather up and display all problems/goals/methods
+1 KILL ^TMP("AMHPTPP",$JOB)
+2 NEW AMHA,AMHB,AMHC,X,Y,Z,AMHL
+3 SET (AMHA,AMHLINE,AMHRCNT)=0
FOR
SET AMHA=$ORDER(^AMHPTPP("AD",AMHTP,AMHA))
IF AMHA'=+AMHA
QUIT
SET AMH0=^AMHPTPP(AMHA,0)
Begin DoDot:1
+4 SET AMHRCNT=$GET(AMHRCNT)+1
+5 SET X=AMHRCNT_") "_IORVON_"Problem: "_IORVOFF_IOINHI_$EXTRACT($PIECE(AMH0,U),1,44)_IOINORM
SET $EXTRACT(X,60)="Status: "_$$VAL^XBDIQ1(9002011.62,AMHA,.12)
DO S
SET ^TMP("AMHPTPP",$JOB,"IDX",AMHRCNT,AMHLINE)=AMHA
+6 SET Y=0
FOR
SET Y=$ORDER(^AMHPTPP(AMHA,11,Y))
IF Y'=+Y
QUIT
SET X=""
SET $EXTRACT(X,5)=^AMHPTPP(AMHA,11,Y,0)
DO S
+7 SET X=" Date Established: "_$$VAL^XBDIQ1(9002011.62,AMHA,.08)
SET $EXTRACT(X,42)="Established by: "_$EXTRACT($$VAL^XBDIQ1(9002011.62,AMHA,.06),1,25)
DO S
+8 SET X=" Date Last Modified: "_$$VAL^XBDIQ1(9002011.62,AMHA,.08)
SET $EXTRACT(X,42)="Modified by: "_$EXTRACT($$VAL^XBDIQ1(9002011.62,AMHA,.06),1,25)
DO S
+9 QUIT
End DoDot:1
+10 ;*** new format
QUIT
WP ;EP - Entry point to print wp fields pass node in AMHNODE
+1 ;PASS FILE IN AMHFILE, ENTRY IN AMHDA
+2 NEW AMHX,AMHPCNT
+3 SET AMHPCNT=0
+4 KILL AMHPRNM
+5 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPTXP(AMHDA,AMHNODE,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+6 SET AMHPCNT=AMHPCNT+1
+7 SET AMHPRNM(AMHPCNT)=^AMHPTXP(AMHDA,AMHNODE,AMHX,0)
+8 QUIT
End DoDot:1
+9 QUIT
NWP ;EP
+1 KILL ^UTILITY($JOB,"W")
+2 SET AMHX=0
+3 SET AMHG=$SELECT($GET(AMHG)]"":AMHG,1:^DIC(AMHFILE,0,"GL"))
SET AMHG=AMHG_AMHDA_","_AMHNODE_",AMHX)"
+4 SET DIWL=$SELECT($GET(AMHCOL):AMHCOL,1:1)
SET DIWR=70
FOR
SET AMHX=$ORDER(@AMHG)
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+5 SET Y=$PIECE(AMHG,")")_",0)"
SET X=$TRANSLATE(@Y,$CHAR(10))
DO ^DIWP
+6 QUIT
End DoDot:1
WPS ;EP
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
SET AMHPCNT=AMHPCNT+1
SET AMHPRNM(AMHPCNT)=^UTILITY($JOB,"W",DIWL,Z,0)
+2 KILL DIWL,DIWR,DIWF,Z
+3 KILL ^UTILITY($JOB,"W"),AMHNODE,AMHFILE,AMHDA,AMHG,AMHCOL
+4 QUIT
S ;
+1 SET AMHLINE=AMHLINE+1
+2 SET ^TMP("AMHPTPP",$JOB,AMHLINE,0)=X
+3 QUIT
EOP ;
+1 WRITE !
SET DIR("A")="Press enter..."
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET AMHQUIT=""
QUIT
+2 QUIT
