- 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
