BCHVD ; IHS/CMI/LAB - BROWSE VISITS ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
;
START ;
NEW BCHX,BCHY,BCHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BCHV,BCHBD,BCHED
NEW D,R
K BCHV
W:$D(IOF) @IOF
W $$CTR("Browse CHR Visits",80)
PAT ;
S DFN=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
I Y<0 W !,"No Patient Selected." Q
S DFN=+Y
S Y=DFN D ^AUPNPAT
WHICH ;
S BCHQUIT=0
S BCHW=""
S DIR(0)="S^L:Patient's Last Visit;N:Patient's Last N Visits;D:Visits in a Date Range;A:All of this Patient's Visits"
S DIR("A")="Browse which subset of visits for "_$P(^DPT(DFN,0),U),DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S BCHW=Y
D @BCHW Q:BCHQUIT
;
BROWSE ;
K ^TMP("BCHVD",$J)
D GATHER
D EN^VALM("BCH BROWSE VISITS")
K ^TMP("BCHVD",$J)
D CLEAR^VALM1
D FULL^VALM1
END ;
K BCHP,BCHQUIT,BCHW
Q
;
EP(DFN) ;EP to list for one patient
NEW BCHX,BCHY,BCHR0,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BCHV,BCHBD,BCHED
D FULL^VALM1
NEW D,R
K BCHV
I '$G(DFN) D PAT Q
W:$D(IOF) @IOF
W $$CTR("Browse CHR Visits",80)
S Y=DFN D ^AUPNPAT
D WHICH
Q
L ;get patients last visit
;BCHV array
I '$D(^BCHR("AE",DFN)) W !!,"No visits on file for this patient.",! S BCHQUIT=1 Q
S D=$O(^BCHR("AE",DFN,"")),R=$O(^BCHR("AE",DFN,D,""))
I R S BCHV(D,R)=""
Q
N ;patients last N visits
S N=""
S DIR(0)="N^1:99:0",DIR("A")="How many visits should be displayed",DIR("B")="5" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S BCHQUIT=1 Q
S N=Y
S (C,D)=0 F S D=$O(^BCHR("AE",DFN,D)) Q:D'=+D!(C=N) S V=0 F S V=$O(^BCHR("AE",DFN,D,V)) Q:V'=+V!(C=N) S C=C+1,BCHV(D,V)=""
Q
A ;all visits
S D=0,V=0
F S D=$O(^BCHR("AE",DFN,D)) Q:D'=+D S V=0 F S V=$O(^BCHR("AE",DFN,D,V)) Q:V'=+V S BCHV(D,V)=""
Q
D ;date range
K BCHED,BCHBD
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date of Visit"
D ^DIR S:Y<1 BCHQUIT=1 Q:Y<1 S BCHBD=Y
K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Date of Visit"
D ^DIR S:Y<1 BCHQUIT=1 Q:Y<1 S BCHED=Y
;
I BCHED<BCHBD D G D
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
S E=9999999-BCHBD,D=9999999-BCHED-1_".99" F S D=$O(^BCHR("AE",DFN,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^BCHR("AE",DFN,D,V)) Q:V'=+V S BCHV(D,V)=""
Q
PRINT ;EP - called from xbdbque
S BCHQUIT=0
;gather up all visit records in ^TMP("BCHVD",$J
D GATHER
D PRINT1
K ^TMP("BCHVD",$J)
Q
;
PRINT1 ;
W:$D(IOF) @IOF
NEW BCHX
S BCHX=0 F S BCHX=$O(^TMP("BCHVD",$J,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT) D
.I $Y>(IOSL-5) D FF Q:BCHQUIT
.W !,^TMP("BCHVD",$J,BCHX,0)
.Q
Q
GATHER ;
K ^TMP("BCHVD",$J)
NEW BCHX,BCHI,BCHJ,BCHY,BCHZ,BCHC,BCHD
S BCHC=0
S X="Patient Name: "_$P(^DPT(DFN,0),U),$E(X,45)="DOB: "_$$FMTE^XLFDT($P(^DPT(DFN,0),U,3)) D S(X)
S X="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2)) D S(X)
S X=$TR($J("",80)," ","*") D S(X)
S BCHV=0,BCHD=0
F S BCHD=$O(BCHV(BCHD)) Q:BCHD'=+BCHD S BCHV=0 F S BCHV=$O(BCHV(BCHD,BCHV)) Q:BCHV'=+BCHV D
.S BCHR0=^BCHR(BCHV,0)
.S X="Visit Date: "_$$FMTE^XLFDT($P(BCHR0,U)),$E(X,45)="Provider: "_$$PPNAME^BCHUTIL(BCHV) D S(X,1)
.S X="Program: "_$$VAL^XBDIQ1(90002,BCHV,.02) D S(X)
.S X="Activity Location: "_$$VAL^XBDIQ1(90002,BCHV,.06),$E(X,45)="Travel Time: "_$$VAL^XBDIQ1(90002,BCHV,.11) D S(X)
.;I $P(BCHR0,U,7)]""!($P(BCHR0,U,8)]"") S X="Referred BY: "_$$VAL^XBDIQ1(90002,BCHV,.07),$E(X,45)="Referred TO: "_$$VAL^XBDIQ1(90002,BCHV,.08) D S(X)
.;table both and print 1,2,3,etc
.NEW BCHREFB,BCHREFT,C
.S X=0,C=0 F S X=$O(^BCHR(BCHV,41,X)) Q:X'=+X S C=C+1,BCHREFB(C)=$P(^BCHTREF($P(^BCHR(BCHV,41,X,0),U),0),U,1)
.S X=0,C=0 F S X=$O(^BCHR(BCHV,42,X)) Q:X'=+X S C=C+1,BCHREFT(C)=$P(^BCHTREF($P(^BCHR(BCHV,42,X,0),U),0),U,1)
.S X="",$E(X)="Referred to CHR by: ",$E(X,45)="Referred by CHR to: " D S(X)
.F X=1:1:20 I $D(BCHREFB(X))!($D(BCHREFT(X))) D
..S Y="",$E(Y,5)=$G(BCHREFB(X)),$E(Y,48)=$G(BCHREFT(X)) D S(Y)
.I $P(BCHR0,U,13)]""!($P(BCHR0,U,14)]"") S X="LMP: "_$$VAL^XBDIQ1(90002,BCHV,.13),$E(X,45)="Fam Plan Method: "_$$VAL^XBDIQ1(90002,BCHV,.14) D S(X)
.F BCHF=1201:1:1210 S BCH1=+$E(BCHF,3,4) I $P($G(^BCHR(BCHV,12)),U,BCH1)]"" S X=$P(^DD(90002,BCHF,0),U,1)_": "_$$VAL^XBDIQ1(90002,BCHV,BCHF) D S(X)
.F BCHF=1301:1:1308 S BCH1=+$E(BCHF,3,4) I $P($G(^BCHR(BCHV,13)),U,BCH1)]"" S X=$P(^DD(90002,BCHF,0),U,1)_": "_$$VAL^XBDIQ1(90002,BCHV,BCHF) D S(X)
.S X="POV's:" D S(X)
.S BCHP=0 F S BCHP=$O(^BCHRPROB("AD",BCHV,BCHP)) Q:BCHP'=+BCHP D
..S X="",$E(X,3)=$$VAL^XBDIQ1(90002.01,BCHP,.01),$E(X,30)=$E($$VAL^XBDIQ1(90002.01,BCHP,.06),1,65) D S(X)
..S X="",$E(X,3)=$$VAL^XBDIQ1(90002.01,BCHP,.04),$E(X,30)=$$VAL^XBDIQ1(90002.01,BCHP,.05) D S(X)
..Q
.;SUB/OBJ
.S X="",$E(X,3)="SUBJECTIVE: " D S(X,1)
.S BCHX=0 F S BCHX=$O(^BCHR(BCHV,51,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT) D
..S X="",$E(X,3)=^BCHR(BCHV,51,BCHX,0) D S(X)
..Q
.S X="",$E(X,3)="OBJECTIVE: " D S(X,1)
.S BCHX=0 F S BCHX=$O(^BCHR(BCHV,61,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT) D
..S X="",$E(X,3)=^BCHR(BCHV,61,BCHX,0) D S(X)
..Q
.S X="",$E(X,3)="PLAN: " D S(X,1)
.S BCHX=0 F S BCHX=$O(^BCHR(BCHV,71,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT) D
..S X="",$E(X,3)=^BCHR(BCHV,71,BCHX,0) D S(X)
..Q
.S X=$TR($J("",80)," ","*") D S(X)
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
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 BCHQUIT=1 Q
I $E(IOST)'="C" Q:'$P(BCHR0,U,8) W !!,$TR($J(" ",79)," ","*"),!,$P(^DPT($P(BCHR0,U,8),0),U),?32,"HRN: " D
.S H=$P($G(^AUPNPAT($P(BCHR0,U,8),41,DUZ(2),0)),U,2)
.W H,?46,"DOB: ",$$FMTE^XLFDT($P(^DPT($P(BCHR0,U,8),0),U,3),"2D"),?59,"SSN: ","XXX-XX-"_$E($P(^DPT($P(BCHR0,U,8),0),U,9),6,9),!
W:$D(IOF) @IOF
Q
HDR ; -- header code
Q
;
S(Y,F,C,T) ;EP - set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW X
;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 BCHC=BCHC+1
S ^TMP("BCHVD",$J,BCHC,0)=X
Q
INIT ; -- init variables and list array
S VALMCNT=$O(^TMP("BCHVD",$J,""),-1)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
BCHVD ; IHS/CMI/LAB - BROWSE VISITS ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ;
START ;
+1 NEW BCHX,BCHY,BCHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BCHV,BCHBD,BCHED
+2 NEW D,R
+3 KILL BCHV
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE $$CTR("Browse CHR Visits",80)
PAT ;
+1 SET DFN=""
+2 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DLAYGO,DIADD
+3 IF Y<0
WRITE !,"No Patient Selected."
QUIT
+4 SET DFN=+Y
+5 SET Y=DFN
DO ^AUPNPAT
WHICH ;
+1 SET BCHQUIT=0
+2 SET BCHW=""
+3 SET DIR(0)="S^L:Patient's Last Visit;N:Patient's Last N Visits;D:Visits in a Date Range;A:All of this Patient's Visits"
+4 SET DIR("A")="Browse which subset of visits for "_$PIECE(^DPT(DFN,0),U)
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 SET BCHW=Y
+7 DO @BCHW
IF BCHQUIT
QUIT
+8 ;
BROWSE ;
+1 KILL ^TMP("BCHVD",$JOB)
+2 DO GATHER
+3 DO EN^VALM("BCH BROWSE VISITS")
+4 KILL ^TMP("BCHVD",$JOB)
+5 DO CLEAR^VALM1
+6 DO FULL^VALM1
END ;
+1 KILL BCHP,BCHQUIT,BCHW
+2 QUIT
+3 ;
EP(DFN) ;EP to list for one patient
+1 NEW BCHX,BCHY,BCHR0,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BCHV,BCHBD,BCHED
+2 DO FULL^VALM1
+3 NEW D,R
+4 KILL BCHV
+5 IF '$GET(DFN)
DO PAT
QUIT
+6 IF $DATA(IOF)
WRITE @IOF
+7 WRITE $$CTR("Browse CHR Visits",80)
+8 SET Y=DFN
DO ^AUPNPAT
+9 DO WHICH
+10 QUIT
L ;get patients last visit
+1 ;BCHV array
+2 IF '$DATA(^BCHR("AE",DFN))
WRITE !!,"No visits on file for this patient.",!
SET BCHQUIT=1
QUIT
+3 SET D=$ORDER(^BCHR("AE",DFN,""))
SET R=$ORDER(^BCHR("AE",DFN,D,""))
+4 IF R
SET BCHV(D,R)=""
+5 QUIT
N ;patients last N visits
+1 SET N=""
+2 SET DIR(0)="N^1:99:0"
SET DIR("A")="How many visits should be displayed"
SET DIR("B")="5"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET BCHQUIT=1
QUIT
+4 SET N=Y
+5 SET (C,D)=0
FOR
SET D=$ORDER(^BCHR("AE",DFN,D))
IF D'=+D!(C=N)
QUIT
SET V=0
FOR
SET V=$ORDER(^BCHR("AE",DFN,D,V))
IF V'=+V!(C=N)
QUIT
SET C=C+1
SET BCHV(D,V)=""
+6 QUIT
A ;all visits
+1 SET D=0
SET V=0
+2 FOR
SET D=$ORDER(^BCHR("AE",DFN,D))
IF D'=+D
QUIT
SET V=0
FOR
SET V=$ORDER(^BCHR("AE",DFN,D,V))
IF V'=+V
QUIT
SET BCHV(D,V)=""
+3 QUIT
D ;date range
+1 KILL BCHED,BCHBD
+2 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date of Visit"
+3 DO ^DIR
IF Y<1
SET BCHQUIT=1
IF Y<1
QUIT
SET BCHBD=Y
+4 KILL DIR
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Ending Date of Visit"
+5 DO ^DIR
IF Y<1
SET BCHQUIT=1
IF Y<1
QUIT
SET BCHED=Y
+6 ;
+7 IF BCHED<BCHBD
Begin DoDot:1
+8 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO D
+9 SET E=9999999-BCHBD
SET D=9999999-BCHED-1_".99"
FOR
SET D=$ORDER(^BCHR("AE",DFN,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^BCHR("AE",DFN,D,V))
IF V'=+V
QUIT
SET BCHV(D,V)=""
+10 QUIT
PRINT ;EP - called from xbdbque
+1 SET BCHQUIT=0
+2 ;gather up all visit records in ^TMP("BCHVD",$J
+3 DO GATHER
+4 DO PRINT1
+5 KILL ^TMP("BCHVD",$JOB)
+6 QUIT
+7 ;
PRINT1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 NEW BCHX
+3 SET BCHX=0
FOR
SET BCHX=$ORDER(^TMP("BCHVD",$JOB,BCHX))
IF BCHX'=+BCHX!(BCHQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-5)
DO FF
IF BCHQUIT
QUIT
+5 WRITE !,^TMP("BCHVD",$JOB,BCHX,0)
+6 QUIT
End DoDot:1
+7 QUIT
GATHER ;
+1 KILL ^TMP("BCHVD",$JOB)
+2 NEW BCHX,BCHI,BCHJ,BCHY,BCHZ,BCHC,BCHD
+3 SET BCHC=0
+4 SET X="Patient Name: "_$PIECE(^DPT(DFN,0),U)
SET $EXTRACT(X,45)="DOB: "_$$FMTE^XLFDT($PIECE(^DPT(DFN,0),U,3))
DO S(X)
+5 SET X="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2))
DO S(X)
+6 SET X=$TRANSLATE($JUSTIFY("",80)," ","*")
DO S(X)
+7 SET BCHV=0
SET BCHD=0
+8 FOR
SET BCHD=$ORDER(BCHV(BCHD))
IF BCHD'=+BCHD
QUIT
SET BCHV=0
FOR
SET BCHV=$ORDER(BCHV(BCHD,BCHV))
IF BCHV'=+BCHV
QUIT
Begin DoDot:1
+9 SET BCHR0=^BCHR(BCHV,0)
+10 SET X="Visit Date: "_$$FMTE^XLFDT($PIECE(BCHR0,U))
SET $EXTRACT(X,45)="Provider: "_$$PPNAME^BCHUTIL(BCHV)
DO S(X,1)
+11 SET X="Program: "_$$VAL^XBDIQ1(90002,BCHV,.02)
DO S(X)
+12 SET X="Activity Location: "_$$VAL^XBDIQ1(90002,BCHV,.06)
SET $EXTRACT(X,45)="Travel Time: "_$$VAL^XBDIQ1(90002,BCHV,.11)
DO S(X)
+13 ;I $P(BCHR0,U,7)]""!($P(BCHR0,U,8)]"") S X="Referred BY: "_$$VAL^XBDIQ1(90002,BCHV,.07),$E(X,45)="Referred TO: "_$$VAL^XBDIQ1(90002,BCHV,.08) D S(X)
+14 ;table both and print 1,2,3,etc
+15 NEW BCHREFB,BCHREFT,C
+16 SET X=0
SET C=0
FOR
SET X=$ORDER(^BCHR(BCHV,41,X))
IF X'=+X
QUIT
SET C=C+1
SET BCHREFB(C)=$PIECE(^BCHTREF($PIECE(^BCHR(BCHV,41,X,0),U),0),U,1)
+17 SET X=0
SET C=0
FOR
SET X=$ORDER(^BCHR(BCHV,42,X))
IF X'=+X
QUIT
SET C=C+1
SET BCHREFT(C)=$PIECE(^BCHTREF($PIECE(^BCHR(BCHV,42,X,0),U),0),U,1)
+18 SET X=""
SET $EXTRACT(X)="Referred to CHR by: "
SET $EXTRACT(X,45)="Referred by CHR to: "
DO S(X)
+19 FOR X=1:1:20
IF $DATA(BCHREFB(X))!($DATA(BCHREFT(X)))
Begin DoDot:2
+20 SET Y=""
SET $EXTRACT(Y,5)=$GET(BCHREFB(X))
SET $EXTRACT(Y,48)=$GET(BCHREFT(X))
DO S(Y)
End DoDot:2
+21 IF $PIECE(BCHR0,U,13)]""!($PIECE(BCHR0,U,14)]"")
SET X="LMP: "_$$VAL^XBDIQ1(90002,BCHV,.13)
SET $EXTRACT(X,45)="Fam Plan Method: "_$$VAL^XBDIQ1(90002,BCHV,.14)
DO S(X)
+22 FOR BCHF=1201:1:1210
SET BCH1=+$EXTRACT(BCHF,3,4)
IF $PIECE($GET(^BCHR(BCHV,12)),U,BCH1)]""
SET X=$PIECE(^DD(90002,BCHF,0),U,1)_": "_$$VAL^XBDIQ1(90002,BCHV,BCHF)
DO S(X)
+23 FOR BCHF=1301:1:1308
SET BCH1=+$EXTRACT(BCHF,3,4)
IF $PIECE($GET(^BCHR(BCHV,13)),U,BCH1)]""
SET X=$PIECE(^DD(90002,BCHF,0),U,1)_": "_$$VAL^XBDIQ1(90002,BCHV,BCHF)
DO S(X)
+24 SET X="POV's:"
DO S(X)
+25 SET BCHP=0
FOR
SET BCHP=$ORDER(^BCHRPROB("AD",BCHV,BCHP))
IF BCHP'=+BCHP
QUIT
Begin DoDot:2
+26 SET X=""
SET $EXTRACT(X,3)=$$VAL^XBDIQ1(90002.01,BCHP,.01)
SET $EXTRACT(X,30)=$EXTRACT($$VAL^XBDIQ1(90002.01,BCHP,.06),1,65)
DO S(X)
+27 SET X=""
SET $EXTRACT(X,3)=$$VAL^XBDIQ1(90002.01,BCHP,.04)
SET $EXTRACT(X,30)=$$VAL^XBDIQ1(90002.01,BCHP,.05)
DO S(X)
+28 QUIT
End DoDot:2
+29 ;SUB/OBJ
+30 SET X=""
SET $EXTRACT(X,3)="SUBJECTIVE: "
DO S(X,1)
+31 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHR(BCHV,51,BCHX))
IF BCHX'=+BCHX!(BCHQUIT)
QUIT
Begin DoDot:2
+32 SET X=""
SET $EXTRACT(X,3)=^BCHR(BCHV,51,BCHX,0)
DO S(X)
+33 QUIT
End DoDot:2
+34 SET X=""
SET $EXTRACT(X,3)="OBJECTIVE: "
DO S(X,1)
+35 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHR(BCHV,61,BCHX))
IF BCHX'=+BCHX!(BCHQUIT)
QUIT
Begin DoDot:2
+36 SET X=""
SET $EXTRACT(X,3)=^BCHR(BCHV,61,BCHX,0)
DO S(X)
+37 QUIT
End DoDot:2
+38 SET X=""
SET $EXTRACT(X,3)="PLAN: "
DO S(X,1)
+39 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHR(BCHV,71,BCHX))
IF BCHX'=+BCHX!(BCHQUIT)
QUIT
Begin DoDot:2
+40 SET X=""
SET $EXTRACT(X,3)=^BCHR(BCHV,71,BCHX,0)
DO S(X)
+41 QUIT
End DoDot:2
+42 SET X=$TRANSLATE($JUSTIFY("",80)," ","*")
DO S(X)
End DoDot:1
+43 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
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 BCHQUIT=1
QUIT
+2 IF $EXTRACT(IOST)'="C"
IF '$PIECE(BCHR0,U,8)
QUIT
WRITE !!,$TRANSLATE($JUSTIFY(" ",79)," ","*"),!,$PIECE(^DPT($PIECE(BCHR0,U,8),0),U),?32,"HRN: "
Begin DoDot:1
+3 SET H=$PIECE($GET(^AUPNPAT($PIECE(BCHR0,U,8),41,DUZ(2),0)),U,2)
+4 WRITE H,?46,"DOB: ",$$FMTE^XLFDT($PIECE(^DPT($PIECE(BCHR0,U,8),0),U,3),"2D"),?59,"SSN: ","XXX-XX-"_$EXTRACT($PIECE(^DPT($PIECE(BCHR0,U,8),0),U,9),6,9),!
End DoDot:1
+5 IF $DATA(IOF)
WRITE @IOF
+6 QUIT
HDR ; -- header code
+1 QUIT
+2 ;
S(Y,F,C,T) ;EP - set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW X
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET BCHC=BCHC+1
+2 SET ^TMP("BCHVD",$JOB,BCHC,0)=X
+3 QUIT
INIT ; -- init variables and list array
+1 SET VALMCNT=$ORDER(^TMP("BCHVD",$JOB,""),-1)
+2 QUIT
+3 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
