AMHLEFP1 ; IHS/CMI/LAB - print form ;
;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
;CMI/TUCSON/LAB - 07/06/98 changed line check from 9 to 10 DEMO+1
;CMI/TUCSON/LAB - 07/06/98 check $G on 11 node of AUPNPAT DEMO+8
DEMO ;EP demographics
I $P(AMHR0,U,8)="" S X="NO PATIENT INFORMATION AVAILABLE" D S(X,2) S X="" D S(X) Q
I '$G(FLAG) S X="BEGIN PATIENT DEMOGRAPHIC DATA" D S(X)
S DFN=$P(AMHR0,U,8)
S AMHHRN=$$HRN^AUPNPAT(DFN,DUZ(2),2)
S:AMHHRN="" AMHHRN="<?????>"
S X="",$E(X,3)="HR#: "_AMHHRN
;NEW %,C,Y S (%,C)=0 F S %=$O(^AUPNPAT(DFN,41,%)) Q:%'=+%!(C>4) I %'=DUZ(2) S X=X_" "_$$HRN^AUPNPAT(DFN,%,2) S C=C+1 PER WENDY AND BJ 7/23/09
D S(X)
S X="",$E(X,3)="NAME: "_$P(^DPT(DFN,0),U) S $E(X,42)="SSN: "_$$SSN^AMHUTIL(DFN) D S(X)
S X="",$E(X,3)="SEX: "_$$EXTSET^XBFUNC(2,.02,$P(^DPT(DFN,0),U,2)),$E(X,30)="TRIBE: " S:$P($G(^AUPNPAT(DFN,11)),U,8)]"" X=X_$P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U) D S(X)
S X="",$E(X,3)="DOB: "_$$FMTE^XLFDT($P(^DPT(DFN,0),U,3)) D S(X)
S X="",$E(X,3)="RESIDENCE: "_$P($G(^AUPNPAT(DFN,11)),U,18) D S(X)
S X="",$E(X,3)="FACILITY: "_$E($P(^DIC(4,DUZ(2),0),U),1,25),$E(X,38)="LOCATION: " S:$P(AMHR0,U,4) X=X_$P(^DIC(4,$P(AMHR0,U,4),0),U) D S(X)
;
I $P($G(^AMHREC(AMHR,11)),U,12)="" D
.S X="",$E(X,20)="PROVIDER SIGNATURE: " D S(X,1)
.S X="",$E(X,3)=$$FMTE^XLFDT($P($P(AMHR0,U),"."))
.S Y=$$PPINT^AMHUTIL(AMHR) I Y S Y=$P($G(^VA(200,Y,3.1)),U,6) I Y]"" S Y=", "_Y
.S $E(X,41)=$$PPNAME^AMHUTIL(AMHR)_Y D S(X)
S X="" D S(X)
S X=$TR($J("",79)," ","*") D S(X)
Q
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("AMHS",$J,"DCS",0),U)+1,$P(^TMP("AMHS",$J,"DCS",0),U)=%
S ^TMP("AMHS",$J,"DCS",%)=X
Q
FF ;EP
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT=1 Q
W:$D(IOF) @IOF
Q
AMHLEFP1 ; IHS/CMI/LAB - print form ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8
+2 ;CMI/TUCSON/LAB - 07/06/98 changed line check from 9 to 10 DEMO+1
+3 ;CMI/TUCSON/LAB - 07/06/98 check $G on 11 node of AUPNPAT DEMO+8
DEMO ;EP demographics
+1 IF $PIECE(AMHR0,U,8)=""
SET X="NO PATIENT INFORMATION AVAILABLE"
DO S(X,2)
SET X=""
DO S(X)
QUIT
+2 IF '$GET(FLAG)
SET X="BEGIN PATIENT DEMOGRAPHIC DATA"
DO S(X)
+3 SET DFN=$PIECE(AMHR0,U,8)
+4 SET AMHHRN=$$HRN^AUPNPAT(DFN,DUZ(2),2)
+5 IF AMHHRN=""
SET AMHHRN="<?????>"
+6 SET X=""
SET $EXTRACT(X,3)="HR#: "_AMHHRN
+7 ;NEW %,C,Y S (%,C)=0 F S %=$O(^AUPNPAT(DFN,41,%)) Q:%'=+%!(C>4) I %'=DUZ(2) S X=X_" "_$$HRN^AUPNPAT(DFN,%,2) S C=C+1 PER WENDY AND BJ 7/23/09
+8 DO S(X)
+9 SET X=""
SET $EXTRACT(X,3)="NAME: "_$PIECE(^DPT(DFN,0),U)
SET $EXTRACT(X,42)="SSN: "_$$SSN^AMHUTIL(DFN)
DO S(X)
+10 SET X=""
SET $EXTRACT(X,3)="SEX: "_$$EXTSET^XBFUNC(2,.02,$PIECE(^DPT(DFN,0),U,2))
SET $EXTRACT(X,30)="TRIBE: "
IF $PIECE($GET(^AUPNPAT(DFN,11)),U,8)]""
SET X=X_$PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8),0),U)
DO S(X)
+11 SET X=""
SET $EXTRACT(X,3)="DOB: "_$$FMTE^XLFDT($PIECE(^DPT(DFN,0),U,3))
DO S(X)
+12 SET X=""
SET $EXTRACT(X,3)="RESIDENCE: "_$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
DO S(X)
+13 SET X=""
SET $EXTRACT(X,3)="FACILITY: "_$EXTRACT($PIECE(^DIC(4,DUZ(2),0),U),1,25)
SET $EXTRACT(X,38)="LOCATION: "
IF $PIECE(AMHR0,U,4)
SET X=X_$PIECE(^DIC(4,$PIECE(AMHR0,U,4),0),U)
DO S(X)
+14 ;
+15 IF $PIECE($GET(^AMHREC(AMHR,11)),U,12)=""
Begin DoDot:1
+16 SET X=""
SET $EXTRACT(X,20)="PROVIDER SIGNATURE: "
DO S(X,1)
+17 SET X=""
SET $EXTRACT(X,3)=$$FMTE^XLFDT($PIECE($PIECE(AMHR0,U),"."))
+18 SET Y=$$PPINT^AMHUTIL(AMHR)
IF Y
SET Y=$PIECE($GET(^VA(200,Y,3.1)),U,6)
IF Y]""
SET Y=", "_Y
+19 SET $EXTRACT(X,41)=$$PPNAME^AMHUTIL(AMHR)_Y
DO S(X)
End DoDot:1
+20 SET X=""
DO S(X)
+21 SET X=$TRANSLATE($JUSTIFY("",79)," ","*")
DO S(X)
+22 QUIT
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 ;blank lines
+4 FOR F=1:1:F
SET X=""
DO S1
+5 SET X=Y
+6 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+7 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+8 FOR %=1:1:T
SET X=" "_Y
+9 DO S1
+10 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("AMHS",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("AMHS",$JOB,"DCS",0),U)=%
+2 SET ^TMP("AMHS",$JOB,"DCS",%)=X
+3 QUIT
FF ;EP
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET AMHQUIT=1
QUIT
+2 IF $DATA(IOF)
WRITE @IOF
+3 QUIT
