AMHLEIVP ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-JAN-1997 ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;; ;
;
EP1 ;EP - called from protocol
D FULL^VALM1
D GETPAT^AMHVRL
I 'AMHPAT W !!,"No patient selected." D PAUSE^AMHLEA Q
NEW DFN,AMHPROGT,AMHR
S DFN=AMHPAT
S AMHPROGT=""
;get program type
I $G(AMHPTYPE)]"" S AMHPROGT=AMHPTYPE G SET
S DIR(0)="S^M:MENTAL HEALTH;S:SOCIAL SERVICES;C:CHEMICAL DEPENDENCY or ALCOHOL/SUBSTANCE ABUSE;O:OTHER",DIR("A")="Which Program are you associated with" K DA D ^DIR K DIR
I $D(DIRUT) W !,"No program selected." D PAUSE^AMHLEA Q
S AMHPROGT=Y
D EN
Q
;
EP(AMHPAT) ;EP CALLED FROM DATA ENTRY
Q:'$G(AMHPAT)
NEW DFN,AMHPROGT,AMHR
S DFN=AMHPAT
S AMHPROGT=""
;get program type
I $G(AMHPTYPE)]"" S AMHPROGT=AMHPTYPE G SET
S DIR(0)="S^M:MENTAL HEALTH;S:SOCIAL SERVICES;C:CHEMICAL DEPENDENCY or ALCOHOL/SUBSTANCE ABUSE;O:OTHER",DIR("A")="Which Program are you associated with" K DA D ^DIR K DIR
I $D(DIRUT) W !,"No program selected." D PAUSE^AMHLEA Q
S AMHPROGT=Y
SET ;
D EN
Q
EN ;EP -- main entry point
NEW AMHX,AMHINTK,AMHD,AMHRCNT,AMHLINE
D EN^VALM("AMH VISIT INTAKE")
Q
;
HDR ; -- header code
D HDR^AMHLEIV
Q
;
INIT ; -- init variables and list array
S VALMSG="?? for more actions + next screen - prev screen"
D GATHER ;gather up all records for display
S VALMCNT=AMHLINE
Q
;
D(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
GATHER ;
D GATHER^AMHLEIV
Q
PRINT ;
S AMHRINTI=""
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." G EXIT
S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
S (X,Y)=0 F S X=$O(AMHINTK("IDX",X)) Q:X'=+X!(AMHRINTI) I $O(AMHINTK("IDX",X,0))=AMHR1 S Y=$O(AMHINTK("IDX",X,0)),AMHRINTI=AMHINTK("IDX",X,Y)
I '$D(^AMHRINTK(AMHRINTI,0)) W !,"Not a valid BH INTAKE." D PAUSE^AMHLEA D EXIT Q
D FULL^VALM1
D PRINT^AMHLEIV3
D EXIT
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K AMHX,AMHINTK,AMHPC,AMHR1
D TERM^VALM0
S VALMBCK="R"
D GATHER
S VALMCNT=AMHLINE
D HDR
K X,Y,Z,I
Q
;
EXPND ; -- expand code
Q
;
AMHLEIVP ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-JAN-1997 ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;; ;
+3 ;
EP1 ;EP - called from protocol
+1 DO FULL^VALM1
+2 DO GETPAT^AMHVRL
+3 IF 'AMHPAT
WRITE !!,"No patient selected."
DO PAUSE^AMHLEA
QUIT
+4 NEW DFN,AMHPROGT,AMHR
+5 SET DFN=AMHPAT
+6 SET AMHPROGT=""
+7 ;get program type
+8 IF $GET(AMHPTYPE)]""
SET AMHPROGT=AMHPTYPE
GOTO SET
+9 SET DIR(0)="S^M:MENTAL HEALTH;S:SOCIAL SERVICES;C:CHEMICAL DEPENDENCY or ALCOHOL/SUBSTANCE ABUSE;O:OTHER"
SET DIR("A")="Which Program are you associated with"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
WRITE !,"No program selected."
DO PAUSE^AMHLEA
QUIT
+11 SET AMHPROGT=Y
+12 DO EN
+13 QUIT
+14 ;
EP(AMHPAT) ;EP CALLED FROM DATA ENTRY
+1 IF '$GET(AMHPAT)
QUIT
+2 NEW DFN,AMHPROGT,AMHR
+3 SET DFN=AMHPAT
+4 SET AMHPROGT=""
+5 ;get program type
+6 IF $GET(AMHPTYPE)]""
SET AMHPROGT=AMHPTYPE
GOTO SET
+7 SET DIR(0)="S^M:MENTAL HEALTH;S:SOCIAL SERVICES;C:CHEMICAL DEPENDENCY or ALCOHOL/SUBSTANCE ABUSE;O:OTHER"
SET DIR("A")="Which Program are you associated with"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
WRITE !,"No program selected."
DO PAUSE^AMHLEA
QUIT
+9 SET AMHPROGT=Y
SET ;
+1 DO EN
+2 QUIT
EN ;EP -- main entry point
+1 NEW AMHX,AMHINTK,AMHD,AMHRCNT,AMHLINE
+2 DO EN^VALM("AMH VISIT INTAKE")
+3 QUIT
+4 ;
HDR ; -- header code
+1 DO HDR^AMHLEIV
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 SET VALMSG="?? for more actions + next screen - prev screen"
+2 ;gather up all records for display
DO GATHER
+3 SET VALMCNT=AMHLINE
+4 QUIT
+5 ;
D(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
GATHER ;
+1 DO GATHER^AMHLEIV
+2 QUIT
PRINT ;
+1 SET AMHRINTI=""
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 IF '$DATA(VALMY)
WRITE !,"No records selected."
GOTO EXIT
+4 SET AMHR1=$ORDER(VALMY(0))
IF 'AMHR1
KILL AMHR1,VALMY,XQORNOD
WRITE !,"No record selected."
GOTO EXIT
+5 SET (X,Y)=0
FOR
SET X=$ORDER(AMHINTK("IDX",X))
IF X'=+X!(AMHRINTI)
QUIT
IF $ORDER(AMHINTK("IDX",X,0))=AMHR1
SET Y=$ORDER(AMHINTK("IDX",X,0))
SET AMHRINTI=AMHINTK("IDX",X,Y)
+6 IF '$DATA(^AMHRINTK(AMHRINTI,0))
WRITE !,"Not a valid BH INTAKE."
DO PAUSE^AMHLEA
DO EXIT
QUIT
+7 DO FULL^VALM1
+8 DO PRINT^AMHLEIV3
+9 DO EXIT
+10 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL AMHX,AMHINTK,AMHPC,AMHR1
+2 DO TERM^VALM0
+3 SET VALMBCK="R"
+4 DO GATHER
+5 SET VALMCNT=AMHLINE
+6 DO HDR
+7 KILL X,Y,Z,I
+8 QUIT
+9 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
