AMHLE3 ; IHS/CMI/LAB - DE CONT. ;
;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
;
;
PHX ;EP
;called from DIE
D EN^XBNEW("EP^AMHLE3","AMHPAT;AUPN*")
Q
PR ;EP
Q:'$G(AMHPAT)
I '$D(^AMHPATR(AMHPAT)) S DIC="^AMHPATR(",DIC(0)="L",DLAYGO=9002011.55,X="`"_AMHPAT D ^DIC D ^XBFMK I Y=-1 W !!,"FAILED TO ADD PATIENT TO BH PATIENT DATA FILE" Q
S DA=AMHPAT,DDSFILE=9002011.55,DR="[AMH PATIENT RELATED DATA]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
Q
EP ;EP
Q:'$G(AMHPAT)
;DISPLAY IN DATE ORDER
;
I '$D(^AMHPPHX("AC",AMHPAT)) W !!,"********** No Personal History currently on file for ",$P(^DPT(AMHPAT,0),U),".",!
S AMHHEAD=" PERSONAL HISTORY FOR "_$P(^DPT(AMHPAT,0),U) D SUBHEAD
S AMHX=0 F S AMHX=$O(^AMHPPHX("AC",AMHPAT,AMHX)) Q:AMHX'=+AMHX D
.S AMHD=$P(^AMHPPHX(AMHX,0),U,3) D DATE
.;W !,AMHD,?11,$E($P(^AMHTPHF($P(^AMHPPHX(AMHX,0),U),0),U),1,25)
.W !,$E($P(^AMHTPHF($P(^AMHPPHX(AMHX,0),U),0),U),1,25)
.Q
;call DIR to get the factor
K DIR S DIR(0)="9002011.52,.01",DIR("A")="Enter PERSONAL HISTORY" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !!,"Bye..." D EOJ Q
S AMHPHX=+Y
I $D(^AMHPPHX("AA",AMHPAT,AMHPHX)) W !!,$P(^AMHTPHF(AMHPHX,0),U)," already recorded for this patient.",!,$C(7),"You may change it or delete it. To delete an entry, enter an '@'.",! D D EOJ Q
.S DIE="^AMHPPHX(",DR=".01",DA=$O(^AMHPPHX("AA",AMHPAT,AMHPHX,0))
.L +^AMHPPHX(DA,0):10 E W !!,"Can't lock global entry." Q
.D ^DIE
.L -^AMHPPHX:10
.K DIE,DA,DR
S DIC(0)="L",DIC="^AMHPPHX(",DLAYGO=9002011.52,DIADD=1,X="`"_AMHPHX K DD S DIC("DR")=".02////^S X=AMHPAT;.03////"_$S($G(AMHDATE)]"":$P(AMHDATE,"."),1:DT) D ^DIC
I Y=-1 W !!,"Adding Personal History of ",$P(^AMHPPHX(AMHPHX,0),U)," failed.",!
K Y
D EOJ
Q
DATE ;
S AMHD=$E(AMHD,4,5)_"/"_$E(AMHD,6,7)_"/"_$E(AMHD,2,3)
Q
;
PEF ;EP - called from AMHLEA - other
S AMHR=%,AMHPAT=%1
K AMHEFT
;W !! S DIR(0)="S^F:Full Encounter Form;S:Suppressed Encounter Form;B:Both a Suppressed & Full;T:2 copies of the Suppressed;E:2 copies of the Full"
;S DIR("A")="What type of form do you want to print"
;S DIR("B")=$S($P(^AMHSITE(DUZ(2),0),U,23)]"":$P(^AMHSITE(DUZ(2),0),U,23),1:"B") K DA D ^DIR K DIR
D FORMDIR^AMHLEFP(AMHR)
Q:$D(DIRUT)
S AMHEFT=Y
S AMHACTN=5
S XBRC="COMP^AMHLEFP",XBRP="^AMHLEFP2",XBNS="AMH",XBRX="XIT^AMHLEFP"
D ^XBDBQUE
K %,%1
Q
EOJ ;EOJ CLEANUP
K DIADD,DLAYGO
D ^XBFMK
K AMHS,AMHX,AMHD,AMHHEAD,AMHPHX
Q
SUBHEAD ;
NEW L
S AMHS="",L=(80-$L(AMHHEAD))/2,$P(AMHS,"*",L)="*"
W !!,AMHS,AMHHEAD,AMHS
Q
AMHLE3 ; IHS/CMI/LAB - DE CONT. ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
+2 ;
+3 ;
PHX ;EP
+1 ;called from DIE
+2 DO EN^XBNEW("EP^AMHLE3","AMHPAT;AUPN*")
+3 QUIT
PR ;EP
+1 IF '$GET(AMHPAT)
QUIT
+2 IF '$DATA(^AMHPATR(AMHPAT))
SET DIC="^AMHPATR("
SET DIC(0)="L"
SET DLAYGO=9002011.55
SET X="`"_AMHPAT
DO ^DIC
DO ^XBFMK
IF Y=-1
WRITE !!,"FAILED TO ADD PATIENT TO BH PATIENT DATA FILE"
QUIT
+3 SET DA=AMHPAT
SET DDSFILE=9002011.55
SET DR="[AMH PATIENT RELATED DATA]"
DO ^DDS
+4 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
SET AMHQUIT=1
KILL DIMSG
QUIT
+5 QUIT
EP ;EP
+1 IF '$GET(AMHPAT)
QUIT
+2 ;DISPLAY IN DATE ORDER
+3 ;
+4 IF '$DATA(^AMHPPHX("AC",AMHPAT))
WRITE !!,"********** No Personal History currently on file for ",$PIECE(^DPT(AMHPAT,0),U),".",!
+5 SET AMHHEAD=" PERSONAL HISTORY FOR "_$PIECE(^DPT(AMHPAT,0),U)
DO SUBHEAD
+6 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPPHX("AC",AMHPAT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+7 SET AMHD=$PIECE(^AMHPPHX(AMHX,0),U,3)
DO DATE
+8 ;W !,AMHD,?11,$E($P(^AMHTPHF($P(^AMHPPHX(AMHX,0),U),0),U),1,25)
+9 WRITE !,$EXTRACT($PIECE(^AMHTPHF($PIECE(^AMHPPHX(AMHX,0),U),0),U),1,25)
+10 QUIT
End DoDot:1
+11 ;call DIR to get the factor
+12 KILL DIR
SET DIR(0)="9002011.52,.01"
SET DIR("A")="Enter PERSONAL HISTORY"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+13 IF $DATA(DIRUT)
WRITE !!,"Bye..."
DO EOJ
QUIT
+14 SET AMHPHX=+Y
+15 IF $DATA(^AMHPPHX("AA",AMHPAT,AMHPHX))
WRITE !!,$PIECE(^AMHTPHF(AMHPHX,0),U)," already recorded for this patient.",!,$CHAR(7),"You may change it or delete it. To delete an entry, enter an '@'.",!
Begin DoDot:1
+16 SET DIE="^AMHPPHX("
SET DR=".01"
SET DA=$ORDER(^AMHPPHX("AA",AMHPAT,AMHPHX,0))
+17 LOCK +^AMHPPHX(DA,0):10
IF '$TEST
WRITE !!,"Can't lock global entry."
QUIT
+18 DO ^DIE
+19 LOCK -^AMHPPHX:10
+20 KILL DIE,DA,DR
End DoDot:1
DO EOJ
QUIT
+21 SET DIC(0)="L"
SET DIC="^AMHPPHX("
SET DLAYGO=9002011.52
SET DIADD=1
SET X="`"_AMHPHX
KILL DD
SET DIC("DR")=".02////^S X=AMHPAT;.03////"_$SELECT($GET(AMHDATE)]"":$PIECE(AMHDATE,"."),1:DT)
DO ^DIC
+22 IF Y=-1
WRITE !!,"Adding Personal History of ",$PIECE(^AMHPPHX(AMHPHX,0),U)," failed.",!
+23 KILL Y
+24 DO EOJ
+25 QUIT
DATE ;
+1 SET AMHD=$EXTRACT(AMHD,4,5)_"/"_$EXTRACT(AMHD,6,7)_"/"_$EXTRACT(AMHD,2,3)
+2 QUIT
+3 ;
PEF ;EP - called from AMHLEA - other
+1 SET AMHR=%
SET AMHPAT=%1
+2 KILL AMHEFT
+3 ;W !! S DIR(0)="S^F:Full Encounter Form;S:Suppressed Encounter Form;B:Both a Suppressed & Full;T:2 copies of the Suppressed;E:2 copies of the Full"
+4 ;S DIR("A")="What type of form do you want to print"
+5 ;S DIR("B")=$S($P(^AMHSITE(DUZ(2),0),U,23)]"":$P(^AMHSITE(DUZ(2),0),U,23),1:"B") K DA D ^DIR K DIR
+6 DO FORMDIR^AMHLEFP(AMHR)
+7 IF $DATA(DIRUT)
QUIT
+8 SET AMHEFT=Y
+9 SET AMHACTN=5
+10 SET XBRC="COMP^AMHLEFP"
SET XBRP="^AMHLEFP2"
SET XBNS="AMH"
SET XBRX="XIT^AMHLEFP"
+11 DO ^XBDBQUE
+12 KILL %,%1
+13 QUIT
EOJ ;EOJ CLEANUP
+1 KILL DIADD,DLAYGO
+2 DO ^XBFMK
+3 KILL AMHS,AMHX,AMHD,AMHHEAD,AMHPHX
+4 QUIT
SUBHEAD ;
+1 NEW L
+2 SET AMHS=""
SET L=(80-$LENGTH(AMHHEAD))/2
SET $PIECE(AMHS,"*",L)="*"
+3 WRITE !!,AMHS,AMHHEAD,AMHS
+4 QUIT
