AMHLEFPP ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
;
;CMI/TUCSON/LAB - added setting of % variable 9/22/97
;
I AMHEFT="B" S AMHEFT="S" D PRINT1 Q:AMHQUIT S AMHEFT="F" D PRINT1 K AMHEFT Q
I AMHEFT="T" S AMHEFT="S" D PRINT1 Q:AMHQUIT S AMHEFT="S" D PRINT1 K AMHEFT Q
I AMHEFT="E" S AMHEFT="F" D PRINT1 Q:AMHQUIT S AMHEFT="F" D PRINT1 K AMEFT Q
PRINT1 ;EP - CALLED FROM LAST VISIT DISPLAY
S AMHR0=^AMHREC(AMHR,0)
S AMHQUIT=0 I $E(IOST,1,2)'="P-" W:$D(IOF) @IOF
W !!?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !?15,"PCC BEHAVIORAL HEALTH ENCOUNTER RECORD"
W !?18,"*** Computer Generated Encounter Record ***"
W !!,$TR($J("",80)," ","*")
I $Y>(IOSL-5) D FF Q:AMHQUIT
W !!?3,"Date: " S Y=$P($P(AMHR0,U),".") D DD^%DT W Y
W ?31,"Primary Provider: ",$$PPNAME^AMHUTIL(AMHR)
S AMHX=0 F S AMHX=$O(^AMHRPROV("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) I $P(^AMHRPROV(AMHX,0),U,4)'="P" W !?35,$P(^VA(200,$P(^AMHRPROV(AMHX,0),U),0),U)
I $Y>(IOSL-5) D FF Q:AMHQUIT
TIME W !?3,"Arrival Time: " S Y=$P(AMHR0,U) D DD^%DT W $P(Y,"@",2) I $P(AMHR0,U,27)]"" W ?31,"Flag: ",$P(AMHR0,U,27)
W !?3,"Program: ",$$EXTSET^XBFUNC(9002011,.02,$P(AMHR0,U,2))
W !?3,"Clinic: " I $P(AMHR0,U,25) W $P(^DIC(40.7,$P(AMHR0,U,25),0),U)
W !?3,"Appointment Type: ",$$EXTSET^XBFUNC(9002011,.11,$P(AMHR0,U,11))
W !,$TR($J("",80)," ","_")
COMM ;
I $Y>(IOSL-7) D FF Q:AMHQUIT
W !?53,"Number",?64,"Activity/Service"
W !?3,"Community: " W:$P(AMHR0,U,5) $E($P(^AUTTCOM($P(AMHR0,U,5),0),U),1,15)
W ?32,"Activity: " I $P(AMHR0,U,6) W $P(^AMHTACT($P(AMHR0,U,6),0),U),"-",$P(^AMHTACT($P(AMHR0,U,6),0),U,8)
W ?53,"Served: ",$P(AMHR0,U,9),?64,"Time: ",$P(AMHR0,U,12)
W !?32,"Type of Contact: " I $P(AMHR0,U,7) W $P(^AMHTSET($P(AMHR0,U,7),0),U)
W !,$TR($J("",80)," ","_")
I $Y>(IOSL-4) D FF Q:AMHQUIT
W !?3,"CHIEF COMPLAINT: " I AMHEFT="F" S AMHTICL=18,AMHTNRQ=$G(^AMHREC(AMHR,21)),AMHTTXT="" D PRTTXT
I AMHEFT="S" W !?3,"Chief Complaint/Presenting Problem Suppressed for Confidentiality",!
SUB W !?3,"SUBJECTIVE/OBJECTIVE: ",!
I AMHEFT="F" S AMHX=0 F S AMHX=$O(^AMHREC(AMHR,31,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
.I $Y>(IOSL-6) D FF Q:AMHQUIT
.W !?4,^AMHREC(AMHR,31,AMHX,0)
.Q
I AMHEFT="S" W ?3,"Mental Health or Social Services Contact",!?3,"See ",$$PPNAME^AMHUTIL(AMHR)," for details.",!
I $Y>(IOSL-5) D FF Q:AMHQUIT
I $D(^AMHREC(AMHR,61))!($P(AMHR0,U,14)]"") D Q:AMHQUIT
.I $Y>(IOSL-5) D FF Q:AMHQUIT
.W !,$TR($J("",80)," ","_")
.W !?3,"AXIS IV: " S Y=0 F S Y=$O(^AMHREC(AMHR,61,Y)) Q:Y'=+Y S I=$P(^AMHREC(AMHR,61,Y,0),U) W ?14,$P(^AMHTAXIV(I,0),U)_" - "_$P(^AMHTAXIV(I,0),U,2),!
.W ?3,"AXIS V: ",$P(AMHR0,U,14)
.Q
W !,$TR($J("",80)," ","_")
W !?3,"BH POV CODE PURPOSE OF VISIT (POV)",!?3,"OR DSM DIAGNOSIS [PRIMARY ON FIRST LINE]"
W !,$TR($J("",80)," ","_")
POV ;
S (AMHX,AMHC)=0 F S AMHX=$O(^AMHRPRO("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
.I $Y>(IOSL-3) D FF Q:AMHQUIT
.W !?8,$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)
.S AMHTNRQ=$S(AMHEFT="F":$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U,2),1:""),AMHTICL=23,AMHTTXT="" D PRTTXT
.S AMHTNRQ=$$GET1^DIQ(9002011.01,AMHX,.04),AMHTICL=23,AMHTTXT="" D PRTTXT
.S AMHC=AMHC+2
.Q
Q:AMHQUIT
F I=AMHC:1:3 D:$Y>(IOSL-3) FF Q:AMHQUIT W !
D:$Y>(IOSL-3) FF Q:AMHQUIT W !,$TR($J("",80)," ","_")
INPT ;
I $P(AMHR0,U,17)]"" D Q:AMHQUIT
.I $Y>(IOSL-4) D FF Q:AMHQUIT
.W ?3,"Inpatient Disposition: ",$$VAL^XBDIQ1(9002011,AMHR,.17),!?3,"Facility: ",$P(AMHR0,U,18)
.W !,$TR($J("",80)," ","_")
.Q
TMP ;treated med problems
W !?3,"TREATED MEDICAL PROBLEMS:"
S (AMHX,AMHC)=0 F S AMHX=$O(^AMHRTMDP("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
.I $Y>(IOSL-3) D FF Q:AMHQUIT
.W !?8,$P(^AUTNPOV($P(^AMHRTMDP(AMHX,0),U),0),U)
.Q
W !,$TR($J("",80)," ","_")
MEDS ;
W !?3,"MEDICATIONS PRESCRIBED:"
S AMHX=0 F S AMHX=$O(^AMHREC(AMHR,41,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
.I $Y>(IOSL-3) D FF Q:AMHQUIT
.W !?4,^AMHREC(AMHR,41,AMHX,0)
.Q
W !,$TR($J("",80)," ","_")
PROC ;
W !?3,"PROCEDURES (CPT):"
S (AMHX,AMHC)=0 F S AMHX=$O(^AMHRPROC("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT) D
.I $Y>(IOSL-3) D FF Q:AMHQUIT
.;W !?8,$P(^ICPT($P(^AMHRPROC(AMHX,0),U),0),U)," ",$P(^ICPT($P(^AMHRPROC(AMHX,0),U),0),U,2)
.W !?8,$P($$CPT^ICPTCOD($P(^AMHRPROC(AMHX,0),U),$P($P(^AMHREC(AMHR,0),U),".")),U,2)_" "_$P($$CPT^ICPTCOD($P(^AMHRPROC(AMHX,0),U),$P($P(^AMHREC(AMHR,0),U),".")),U,3)
.Q
W !,$TR($J("",80)," ","_")
I $Y>(IOSL-4) D FF Q:AMHQUIT
S %="" W !?3,"COMMENT:",! ;CMI/TUCSON/LAB - added setting of % 09/22/97
I AMHEFT="S",$P($G(^AMHSITE(DUZ(2),0)),U,27)'="N" S %=0
I AMHEFT="F" S %=1
I AMHEFT="S",$P($G(^AMHSITE(DUZ(2),0)),U,27)="N" S %=1
I '% W !
I % D
.S AMHTICL=4,AMHTNRQ=$G(^AMHREC(AMHR,12)),AMHTTXT=""
.I AMHTNRQ]"" D PRTTXT
W !,$TR($J("",80)," ","_")
DEMO ;EP demographics
D DEMO^AMHLEFP1
Q
PRTTXT ; GENERALIZED TEXT PRINTER
S AMHTDLT=1,AMHTILN=80-AMHTICL-1
F AMHTQ=0:0 S:AMHTNRQ]""&(($L(AMHTNRQ)+$L(AMHTTXT)+2)<255) AMHTTXT=$S(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ,AMHTNRQ="" Q:AMHTTXT="" D PRTTXT2
K AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
Q
PRTTXT2 D GETFRAG W ?AMHTICL W AMHTF,! S AMHTICL=AMHTICL+AMHTDLT,AMHTILN=AMHTILN-AMHTDLT,AMHTDLT=0
Q
GETFRAG I $L(AMHTTXT)<AMHTILN S AMHTF=AMHTTXT,AMHTTXT="" Q
F AMHTC=AMHTILN:-1:1 Q:$E(AMHTTXT,AMHTC)=" "
S AMHTF=$E(AMHTTXT,1,AMHTC-1),AMHTTXT=$E(AMHTTXT,AMHTC+1,255)
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
I $E(IOST)'="C" Q:'$P(AMHR0,U,8) W !!,$TR($J(" ",79)," ","*"),!,$P(^DPT($P(AMHR0,U,8),0),U),?32,"HRN: " D
.S AMHHRN=$P($G(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2),0)),U,2)
.W AMHHRN,?46,"DOB: ",$$FMTE^XLFDT($P(^DPT($P(AMHR0,U,8),0),U,3),"2D"),?59,"SSN: ",$$SSN^AMHUTIL($P(AMHR0,U,8)),!
W:$D(IOF) @IOF
Q
AMHLEFPP ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
+2 ;
+3 ;CMI/TUCSON/LAB - added setting of % variable 9/22/97
+4 ;
+5 IF AMHEFT="B"
SET AMHEFT="S"
DO PRINT1
IF AMHQUIT
QUIT
SET AMHEFT="F"
DO PRINT1
KILL AMHEFT
QUIT
+6 IF AMHEFT="T"
SET AMHEFT="S"
DO PRINT1
IF AMHQUIT
QUIT
SET AMHEFT="S"
DO PRINT1
KILL AMHEFT
QUIT
+7 IF AMHEFT="E"
SET AMHEFT="F"
DO PRINT1
IF AMHQUIT
QUIT
SET AMHEFT="F"
DO PRINT1
KILL AMEFT
QUIT
PRINT1 ;EP - CALLED FROM LAST VISIT DISPLAY
+1 SET AMHR0=^AMHREC(AMHR,0)
+2 SET AMHQUIT=0
IF $EXTRACT(IOST,1,2)'="P-"
IF $DATA(IOF)
WRITE @IOF
+3 WRITE !!?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+4 WRITE !?15,"PCC BEHAVIORAL HEALTH ENCOUNTER RECORD"
+5 WRITE !?18,"*** Computer Generated Encounter Record ***"
+6 WRITE !!,$TRANSLATE($JUSTIFY("",80)," ","*")
+7 IF $Y>(IOSL-5)
DO FF
IF AMHQUIT
QUIT
+8 WRITE !!?3,"Date: "
SET Y=$PIECE($PIECE(AMHR0,U),".")
DO DD^%DT
WRITE Y
+9 WRITE ?31,"Primary Provider: ",$$PPNAME^AMHUTIL(AMHR)
+10 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRPROV("AD",AMHR,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
IF $PIECE(^AMHRPROV(AMHX,0),U,4)'="P"
WRITE !?35,$PIECE(^VA(200,$PIECE(^AMHRPROV(AMHX,0),U),0),U)
+11 IF $Y>(IOSL-5)
DO FF
IF AMHQUIT
QUIT
TIME WRITE !?3,"Arrival Time: "
SET Y=$PIECE(AMHR0,U)
DO DD^%DT
WRITE $PIECE(Y,"@",2)
IF $PIECE(AMHR0,U,27)]""
WRITE ?31,"Flag: ",$PIECE(AMHR0,U,27)
+1 WRITE !?3,"Program: ",$$EXTSET^XBFUNC(9002011,.02,$PIECE(AMHR0,U,2))
+2 WRITE !?3,"Clinic: "
IF $PIECE(AMHR0,U,25)
WRITE $PIECE(^DIC(40.7,$PIECE(AMHR0,U,25),0),U)
+3 WRITE !?3,"Appointment Type: ",$$EXTSET^XBFUNC(9002011,.11,$PIECE(AMHR0,U,11))
+4 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
COMM ;
+1 IF $Y>(IOSL-7)
DO FF
IF AMHQUIT
QUIT
+2 WRITE !?53,"Number",?64,"Activity/Service"
+3 WRITE !?3,"Community: "
IF $PIECE(AMHR0,U,5)
WRITE $EXTRACT($PIECE(^AUTTCOM($PIECE(AMHR0,U,5),0),U),1,15)
+4 WRITE ?32,"Activity: "
IF $PIECE(AMHR0,U,6)
WRITE $PIECE(^AMHTACT($PIECE(AMHR0,U,6),0),U),"-",$PIECE(^AMHTACT($PIECE(AMHR0,U,6),0),U,8)
+5 WRITE ?53,"Served: ",$PIECE(AMHR0,U,9),?64,"Time: ",$PIECE(AMHR0,U,12)
+6 WRITE !?32,"Type of Contact: "
IF $PIECE(AMHR0,U,7)
WRITE $PIECE(^AMHTSET($PIECE(AMHR0,U,7),0),U)
+7 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+8 IF $Y>(IOSL-4)
DO FF
IF AMHQUIT
QUIT
+9 WRITE !?3,"CHIEF COMPLAINT: "
IF AMHEFT="F"
SET AMHTICL=18
SET AMHTNRQ=$GET(^AMHREC(AMHR,21))
SET AMHTTXT=""
DO PRTTXT
+10 IF AMHEFT="S"
WRITE !?3,"Chief Complaint/Presenting Problem Suppressed for Confidentiality",!
SUB WRITE !?3,"SUBJECTIVE/OBJECTIVE: ",!
+1 IF AMHEFT="F"
SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHR,31,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-6)
DO FF
IF AMHQUIT
QUIT
+3 WRITE !?4,^AMHREC(AMHR,31,AMHX,0)
+4 QUIT
End DoDot:1
+5 IF AMHEFT="S"
WRITE ?3,"Mental Health or Social Services Contact",!?3,"See ",$$PPNAME^AMHUTIL(AMHR)," for details.",!
+6 IF $Y>(IOSL-5)
DO FF
IF AMHQUIT
QUIT
+7 IF $DATA(^AMHREC(AMHR,61))!($PIECE(AMHR0,U,14)]"")
Begin DoDot:1
+8 IF $Y>(IOSL-5)
DO FF
IF AMHQUIT
QUIT
+9 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+10 WRITE !?3,"AXIS IV: "
SET Y=0
FOR
SET Y=$ORDER(^AMHREC(AMHR,61,Y))
IF Y'=+Y
QUIT
SET I=$PIECE(^AMHREC(AMHR,61,Y,0),U)
WRITE ?14,$PIECE(^AMHTAXIV(I,0),U)_" - "_$PIECE(^AMHTAXIV(I,0),U,2),!
+11 WRITE ?3,"AXIS V: ",$PIECE(AMHR0,U,14)
+12 QUIT
End DoDot:1
IF AMHQUIT
QUIT
+13 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+14 WRITE !?3,"BH POV CODE PURPOSE OF VISIT (POV)",!?3,"OR DSM DIAGNOSIS [PRIMARY ON FIRST LINE]"
+15 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
POV ;
+1 SET (AMHX,AMHC)=0
FOR
SET AMHX=$ORDER(^AMHRPRO("AD",AMHR,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-3)
DO FF
IF AMHQUIT
QUIT
+3 WRITE !?8,$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)
+4 SET AMHTNRQ=$SELECT(AMHEFT="F":$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U,2),1:"")
SET AMHTICL=23
SET AMHTTXT=""
DO PRTTXT
+5 SET AMHTNRQ=$$GET1^DIQ(9002011.01,AMHX,.04)
SET AMHTICL=23
SET AMHTTXT=""
DO PRTTXT
+6 SET AMHC=AMHC+2
+7 QUIT
End DoDot:1
+8 IF AMHQUIT
QUIT
+9 FOR I=AMHC:1:3
IF $Y>(IOSL-3)
DO FF
IF AMHQUIT
QUIT
WRITE !
+10 IF $Y>(IOSL-3)
DO FF
IF AMHQUIT
QUIT
WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
INPT ;
+1 IF $PIECE(AMHR0,U,17)]""
Begin DoDot:1
+2 IF $Y>(IOSL-4)
DO FF
IF AMHQUIT
QUIT
+3 WRITE ?3,"Inpatient Disposition: ",$$VAL^XBDIQ1(9002011,AMHR,.17),!?3,"Facility: ",$PIECE(AMHR0,U,18)
+4 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+5 QUIT
End DoDot:1
IF AMHQUIT
QUIT
TMP ;treated med problems
+1 WRITE !?3,"TREATED MEDICAL PROBLEMS:"
+2 SET (AMHX,AMHC)=0
FOR
SET AMHX=$ORDER(^AMHRTMDP("AD",AMHR,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-3)
DO FF
IF AMHQUIT
QUIT
+4 WRITE !?8,$PIECE(^AUTNPOV($PIECE(^AMHRTMDP(AMHX,0),U),0),U)
+5 QUIT
End DoDot:1
+6 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
MEDS ;
+1 WRITE !?3,"MEDICATIONS PRESCRIBED:"
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHR,41,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-3)
DO FF
IF AMHQUIT
QUIT
+4 WRITE !?4,^AMHREC(AMHR,41,AMHX,0)
+5 QUIT
End DoDot:1
+6 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
PROC ;
+1 WRITE !?3,"PROCEDURES (CPT):"
+2 SET (AMHX,AMHC)=0
FOR
SET AMHX=$ORDER(^AMHRPROC("AD",AMHR,AMHX))
IF AMHX'=+AMHX!(AMHQUIT)
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-3)
DO FF
IF AMHQUIT
QUIT
+4 ;W !?8,$P(^ICPT($P(^AMHRPROC(AMHX,0),U),0),U)," ",$P(^ICPT($P(^AMHRPROC(AMHX,0),U),0),U,2)
+5 WRITE !?8,$PIECE($$CPT^ICPTCOD($PIECE(^AMHRPROC(AMHX,0),U),$PIECE($PIECE(^AMHREC(AMHR,0),U),".")),U,2)_" "_$PIECE($$CPT^ICPTCOD($PIECE(^AMHRPROC(AMHX,0),U),$PIECE($PIECE(^AMHREC(AMHR,0),U),".")),U,3)
+6 QUIT
End DoDot:1
+1 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+2 IF $Y>(IOSL-4)
DO FF
IF AMHQUIT
QUIT
+3 ;CMI/TUCSON/LAB - added setting of % 09/22/97
SET %=""
WRITE !?3,"COMMENT:",!
+4 IF AMHEFT="S"
IF $PIECE($GET(^AMHSITE(DUZ(2),0)),U,27)'="N"
SET %=0
+5 IF AMHEFT="F"
SET %=1
+6 IF AMHEFT="S"
IF $PIECE($GET(^AMHSITE(DUZ(2),0)),U,27)="N"
SET %=1
+7 IF '%
WRITE !
+8 IF %
Begin DoDot:1
+9 SET AMHTICL=4
SET AMHTNRQ=$GET(^AMHREC(AMHR,12))
SET AMHTTXT=""
+10 IF AMHTNRQ]""
DO PRTTXT
End DoDot:1
+11 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
DEMO ;EP demographics
+1 DO DEMO^AMHLEFP1
+2 QUIT
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET AMHTDLT=1
SET AMHTILN=80-AMHTICL-1
+2 FOR AMHTQ=0:0
IF AMHTNRQ]""&(($LENGTH(AMHTNRQ)+$LENGTH(AMHTTXT)+2)<255)
SET AMHTTXT=$SELECT(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ
SET AMHTNRQ=""
IF AMHTTXT=""
QUIT
DO PRTTXT2
+3 KILL AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
+4 QUIT
PRTTXT2 DO GETFRAG
WRITE ?AMHTICL
WRITE AMHTF,!
SET AMHTICL=AMHTICL+AMHTDLT
SET AMHTILN=AMHTILN-AMHTDLT
SET AMHTDLT=0
+1 QUIT
GETFRAG IF $LENGTH(AMHTTXT)<AMHTILN
SET AMHTF=AMHTTXT
SET AMHTTXT=""
QUIT
+1 FOR AMHTC=AMHTILN:-1:1
IF $EXTRACT(AMHTTXT,AMHTC)=" "
QUIT
+2 SET AMHTF=$EXTRACT(AMHTTXT,1,AMHTC-1)
SET AMHTTXT=$EXTRACT(AMHTTXT,AMHTC+1,255)
+3 QUIT
+4 ;
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 $EXTRACT(IOST)'="C"
IF '$PIECE(AMHR0,U,8)
QUIT
WRITE !!,$TRANSLATE($JUSTIFY(" ",79)," ","*"),!,$PIECE(^DPT($PIECE(AMHR0,U,8),0),U),?32,"HRN: "
Begin DoDot:1
+3 SET AMHHRN=$PIECE($GET(^AUPNPAT($PIECE(AMHR0,U,8),41,DUZ(2),0)),U,2)
+4 WRITE AMHHRN,?46,"DOB: ",$$FMTE^XLFDT($PIECE(^DPT($PIECE(AMHR0,U,8),0),U,3),"2D"),?59,"SSN: ",$$SSN^AMHUTIL($PIECE(AMHR0,U,8)),!
End DoDot:1
+5 IF $DATA(IOF)
WRITE @IOF
+6 QUIT
