BCHUFPP ; IHS/CMI/LAB - PRINT CHR FORMS ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - patch 8 Y2K
;
;IHS/TUCSON/LAB - patch 1 06/03/97 - modified so subj/obj data
;would display.
;
PRINT1 ;EP - CALLED FROM LAST VISIT DISPLAY
S BCHR0=^BCHR(BCHR,0)
S BCHQUIT=0
I $E(IOST)="C" W:$D(IOF) @IOF
W !!!?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !?34,"CHR PCC FORM"
W !?18,"*** Computer Generated Encounter Record ***"
W !,$TR($J("",80)," ","*")
I $Y>(IOSL-6) D FF Q:BCHQUIT
W !?3,"Date of Service: " S Y=$P($P(BCHR0,U),".") D DD^%DT W Y
W !?3,"Temporary Residence: ",$P($G(^BCHR(BCHR,11)),U,8),!?35,"Program Code: ",$P(^BCHTPROG($P(BCHR0,U,2),0),U,5)
W !?35,"Provider (CHR): ",$$PPNAME^BCHUTIL(BCHR)
W !,$TR($J("",80)," ","_")
SUB ;
;IHS/TUCSON/LAB - modified to display subjective info patch 1 06/03/97
S BCHR12=$G(^BCHR(BCHR,12))
S BCHR13=$G(^BCHR(BCHR,13))
I $Y>(IOSL-5) D FF Q:BCHQUIT
W !?3,"SUBJECTIVE INFORMATION (includes patient's complaint)",?65,"TEMP ",$P(BCHR12,U,7)
S BCHDA=BCHR,BCHFILE=90002,BCHNODE=51,BCHIOM=58 D WP
S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="PULSE "_$P(BCHR12,U,8)
S BCHWP(2)=$G(BCHWP(2)),$E(BCHWP(2),62)="RESP "_$P(BCHR12,U,9)
S BCHWP(3)=$G(BCHWP(3)),$E(BCHWP(3),62)="BP "_$P(BCHR12,U,1)
S BCHWP(4)=$G(BCHWP(4)),$E(BCHWP(4),62)="WT "_$P(BCHR12,U,2)
S BCHWP(5)=$G(BCHWP(5)),$E(BCHWP(5),62)="HT "_$P(BCHR12,U,3)
S BCHX1=0 F S BCHX1=$O(BCHWP(BCHX1)) Q:BCHX1'=+BCHX1!(BCHQUIT) D
.I $Y>(IOSL-4) D FF Q:BCHQUIT
.W !?4,BCHWP(BCHX1)
.Q
I $Y>(IOSL-7) D FF Q:BCHQUIT
OBJ ;
;IHS/TUCSON/LAB - modified to display objective info patch 1 06/03/97
W !,$TR($J("",80)," ","_")
W !?3,"OBJECTIVE DATA",?65,"HEAD ",$P(BCHR12,U,4)
S BCHDA=BCHR,BCHFILE=90002,BCHNODE=61,BCHIOM=58 D WP
S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="BMI "_$P(BCHR12,U,12)
S BCHWP(2)=$G(BCHWP(2)),$E(BCHWP(2),62)="WAIST "_$P(BCHR12,U,11)
S BCHWP(3)=$G(BCHWP(3)),$E(BCHWP(3),62)="VU "_$P(BCHR12,U,5)
S BCHWP(4)=$G(BCHWP(4)),$E(BCHWP(4),62)="VC "_$P(BCHR12,U,6)
S BCHX1=0 F S BCHX1=$O(BCHWP(BCHX1)) Q:BCHX1'=+BCHX1!(BCHQUIT) D
.I $Y>(IOSL-4) D FF Q:BCHQUIT
.W !?4,BCHWP(BCHX1)
.Q
W !,$TR($J("",80)," ","_")
POV ;
I $Y>(IOSL-6) D FF Q:BCHQUIT
W !?3,"ASSESSMENT - PCC Purpose of Visit"
W !?3,"Hlth Prob",?13,"Svc",?18,"Svc",?30,"Narrative" ;,?60,"Sub"
W !?5,"Code",?13,"Code",?18,"Mins",?65,"Tests"
W !,$TR($J("",80)," ","_")
S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT) S BCHC=BCHC+1 D
.I $Y>(IOSL-5) D FF Q:BCHQUIT
.S BCHRNODE=^BCHRPROB(BCHX,0)
.W !?6,$P(^BCHTPROB($P(BCHRNODE,U),0),U,2)
.W ?14,$S($P(BCHRNODE,U,4)]"":$P(^BCHTSERV($P(BCHRNODE,U,4),0),U,3),1:"??")
.W ?19,$P(^BCHRPROB(BCHX,0),U,5)
.S BCHTNRQ=$P(^BCHRPROB(BCHX,0),U,6) S BCHTNRQ=$S(BCHTNRQ]"":$P(^AUTNPOV(BCHTNRQ,0),U),1:"<<none>>") S BCHW=35 D WRT ;IHS/TUCSON/LAB - patch 2
.W ?23,BCHRPRNM(1) W:BCHC=1 ?65,"PPD ",$P(BCHR12,U,10)
.;begin Y2K
.;W ! W:$D(BCHRPRNM(2)) ?23,BCHRPRNM(2) W:BCHC=1 ?65,"BS ",$S($P(BCHR13,U,2)]"":$P(BCHR13,U,2),$P(BCHR13,U)]"":$E($P(BCHR13,U),4,5)_"/"_$E($P(BCHR13,U),6,7)_"/"_$E($P(BCHR13,U),2,3),1:"") ;Y2000
.W ! W:$D(BCHRPRNM(2)) ?23,BCHRPRNM(2) W:BCHC=1 ?65,"BG ",$S($P(BCHR13,U,2)]"":$P(BCHR13,U,2),$P(BCHR13,U)]"":$E($P(BCHR0,U),4,5)_"/"_$E($P(BCHR0,U),6,7)_"/"_(1700+($E($P(BCHR0,U),1,3))),1:"") ;Y2000
.;W ! W:$D(BCHRPRNM(3)) ?23,BCHRPRNM(3) W:BCHC=1 ?65,"T/C ",$S($P(BCHR13,U,4)]"":$P(BCHR13,U,4),$P(BCHR13,U,3)]"":$E($P(BCHR13,U,3),4,5)_"/"_$E($P(BCHR13,U,3),6,7)_"/"_$E($P(BCHR13,U,3),2,3),1:"") ;Y2000
.;W ! W:$D(BCHRPRNM(3)) ?23,BCHRPRNM(3) W:BCHC=1 ?65,"T/C ",$S($P(BCHR13,U,4)]"":$P(BCHR13,U,4),$P(BCHR13,U,3)]"":$E($P(BCHR13,U,3),4,5)_"/"_$E($P(BCHR13,U,3),6,7)_"/"_(1700+($E($P(BCHR13,U,3),1,3))),1:"") ;Y2000
.W ! W:$D(BCHRPRNM(4)) ?23,BCHRPRNM(4) W:BCHC=1 ?58,"Hemoglobin A1c ",$S($P(BCHR13,U,9)]"":$P(BCHR13,U,9),1:"")
.;W ! W:$D(BCHRPRNM(5)) ?23,BCHRPRNM(5) W:BCHC=1 ?58,"Total Cholesterol ",$S($P(BCHR13,U,10)]"":$P(BCHR13,U,10),1:"")
.;end Y2K
.Q
S BCHX1=3 F S BCHX1=$O(BCHRPRNM(BCHX1)) Q:BCHX1'=+BCHX1!(BCHQUIT) D:$Y>(IOSL-4) FF Q:BCHQUIT W !?23,BCHRPRNM(BCHX1)
K BCHRPRNM,BCHX1
Q:BCHQUIT
PLANS ;
;IHS/TUCSON/LAB - modified to display plan info patch 1 06/03/97
I $Y>(IOSL-7) D FF Q:BCHQUIT
W !,$TR($J("",80)," ","_")
W !?3,"Plans/Treatments"
;begin Y2K
;W ?65,"HCT ",$S($P(BCHR13,U,8)]"":$P(BCHR13,U,8),$P(BCHR13,U,7)]"":$E($P(BCHR13,U,7),4,5)_"/"_$E($P(BCHR13,U,7),6,7)_"/"_$E($P(BCHR13,U,7),2,3),1:"") ;Y2000
W ?65,"HCT ",$S($P(BCHR13,U,8)]"":$P(BCHR13,U,8),$P(BCHR13,U,7)]"":$E($P(BCHR13,U,7),4,5)_"/"_$E($P(BCHR13,U,7),6,7)_"/"_(1700+($E($P(BCHR13,U,7),1,3))),1:"") ;Y2000
;end Y2K
S BCHDA=BCHR,BCHFILE=90002,BCHNODE=71,BCHIOM=52 D WP
;W !?65,"UA ",$S($P(BCHR13,U,8)]"":$P(BCHR13,U,8),$P(BCHR13,U,7)]"":$E($P(BCHR13,U,7),4,5)_"/"_$E($P(BCHR13,U,7),6,7)_"/"_$E($P(BCHR13,U,7),2,3),1:"")
;begin Y2K
;S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="UA "_$S($P(BCHR13,U,6)]"":$P(BCHR13,U,6),$P(BCHR13,U,5)]"":$E($P(BCHR13,U,5),4,5)_"/"_$E($P(BCHR13,U,5),6,7)_"/"_$E($P(BCHR13,U,5),2,3),1:"") ;Y2000
;S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="UA "_$S($P(BCHR13,U,6)]"":$P(BCHR13,U,6),$P(BCHR13,U,5)]"":$E($P(BCHR13,U,5),4,5)_"/"_$E($P(BCHR13,U,5),6,7)_"/"_(1700+($E($P(BCHR13,U,5),1,3))),1:"")
;end Y2K
S BCHWP(2)=$G(BCHWP(2)),$E(BCHWP(2),55)="Reproductive Factors"
;begin Y2K
;S BCHWP(3)=$G(BCHWP(3)),$E(BCHWP(3),55)="LMP " S:$P(BCHR0,U,13)]"" BCHWP(3)=BCHWP(3)_$E($P(BCHR0,U,13),4,5)_"/"_$E($P(BCHR0,U,13),6,7)_"/"_$E($P(BCHR0,U,13),2,3) ;Y2000
S BCHWP(3)=$G(BCHWP(3)),$E(BCHWP(3),55)="LMP " S:$P(BCHR0,U,13)]"" BCHWP(3)=BCHWP(3)_$E($P(BCHR0,U,13),4,5)_"/"_$E($P(BCHR0,U,13),6,7)_"/"_(1700+($E($P(BCHR0,U,13),1,3))) ;Y2000
;end Y2K
S BCHWP(4)=$G(BCHWP(4)),$E(BCHWP(4),55)="FP "_$S($P(BCHR0,U,14)]"":$P(^BCHTFPM($P(BCHR0,U,14),0),U),1:"")
S BCHX1=0 F S BCHX1=$O(BCHWP(BCHX1)) Q:BCHX1'=+BCHX1!(BCHQUIT) D
.I $Y>(IOSL-4) D FF Q:BCHQUIT
.W !?4,BCHWP(BCHX1)
.Q
I $Y>(IOSL-3) D FF Q:BCHQUIT
;W !?3,"Education Topics recorded"
;S BCHX=0 F S BCHX=$O(^BCHRPED("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
;.W !?3,$E($$VAL^XBDIQ1(90002.02,BCHX,.01),1,38),?40,$E($$VAL^XBDIQ1(90002.02,BCHX,.06),1,10),?51,$E($$VAL^XBDIQ1(90002.02,BCHX,.07),1,10),?62,$$VAL^XBDIQ1(90002.02,BCHX,.08)_" MIN",?69,"OBJ: ",$$VAL^XBDIQ1(90002.02,BCHX,.14)
W !,$TR($J("",80)," ","_")
ACT ;
I $Y>(IOSL-5) D FF Q:BCHQUIT
W !?3,"Activity Location: ",$S($P(BCHR0,U,6)]"":$P(^BCHTACTL($P(BCHR0,U,6),0),U),1:"") I $P(BCHR0,U,5)]"" W ?40,"Hospital/Clinic: ",$E($P(^DIC(4,$P(BCHR0,U,5),0),U),1,22)
;table both and print 1,2,3,etc
NEW BCHREFB,BCHREFT,C
S X=0,C=0 F S X=$O(^BCHR(BCHR,41,X)) Q:X'=+X S C=C+1,BCHREFB(C)=$P(^BCHTREF($P(^BCHR(BCHR,41,X,0),U),0),U,1)
S X=0,C=0 F S X=$O(^BCHR(BCHR,42,X)) Q:X'=+X S C=C+1,BCHREFT(C)=$P(^BCHTREF($P(^BCHR(BCHR,42,X,0),U),0),U,1)
W !?3,"Referred to CHR by: ",?45,"Referred by CHR to: "
F X=1:1:20 I $D(BCHREFB(X))!($D(BCHREFT(X))) D
.W !?5,$G(BCHREFB(X)),?48,$G(BCHREFT(X))
W !?3,"Travel Time: ",$P(BCHR0,U,11),?45,"Number Served: ",$P(BCHR0,U,12)
W !,$TR($J("",80)," ","_"),!
DEMO ;demographics
D DEMO^BCHUFP
Q
WRT ;EP - Entry point to print wp fields pass node in BCHNODE
K ^UTILITY($J,"W"),BCHRPRNM
S BCHPCNT=0
S DIWL=1,DIWR=35,X=BCHTNRQ D ^DIWP
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S BCHPCNT=BCHPCNT+1,BCHRPRNM(BCHPCNT)=^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),BCHNODE,BCHFILE,BCHDA
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 BCHQUIT=1 Q
W:$D(IOF) @IOF
Q
WP ;EP - Entry point to print wp fields pass node in BCHWP
;PASS FILE IN BCHFILE, ENTRY IN BCHDA
NEW G,P,BCHX
K BCHWP
K ^UTILITY($J,"W")
S BCHX=0,P=0
S G=$S($G(G)]"":G,1:^DIC(BCHFILE,0,"GL")),G=G_BCHDA_","_BCHNODE_",BCHX)"
S DIWR=$S($G(BCHIOM):BCHIOM,1:IOM),DIWL=0 F S BCHX=$O(@G) Q:BCHX'=+BCHX D
.S Y=$P(G,")")_",0)"
.S X="" I $G(BCHCAP)]"",BCHX=1 S X=BCHCAP
.S X=X_@Y D ^DIWP
.Q
WPS ;EP
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S P=P+1,BCHWP(P)=^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),BCHNODE,BCHFILE,BCHDA,G,BCHCOL,BCHCAP
Q
BCHUFPP ; IHS/CMI/LAB - PRINT CHR FORMS ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - patch 8 Y2K
+3 ;
+4 ;IHS/TUCSON/LAB - patch 1 06/03/97 - modified so subj/obj data
+5 ;would display.
+6 ;
PRINT1 ;EP - CALLED FROM LAST VISIT DISPLAY
+1 SET BCHR0=^BCHR(BCHR,0)
+2 SET BCHQUIT=0
+3 IF $EXTRACT(IOST)="C"
IF $DATA(IOF)
WRITE @IOF
+4 WRITE !!!?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+5 WRITE !?34,"CHR PCC FORM"
+6 WRITE !?18,"*** Computer Generated Encounter Record ***"
+7 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","*")
+8 IF $Y>(IOSL-6)
DO FF
IF BCHQUIT
QUIT
+9 WRITE !?3,"Date of Service: "
SET Y=$PIECE($PIECE(BCHR0,U),".")
DO DD^%DT
WRITE Y
+10 WRITE !?3,"Temporary Residence: ",$PIECE($GET(^BCHR(BCHR,11)),U,8),!?35,"Program Code: ",$PIECE(^BCHTPROG($PIECE(BCHR0,U,2),0),U,5)
+11 WRITE !?35,"Provider (CHR): ",$$PPNAME^BCHUTIL(BCHR)
+12 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
SUB ;
+1 ;IHS/TUCSON/LAB - modified to display subjective info patch 1 06/03/97
+2 SET BCHR12=$GET(^BCHR(BCHR,12))
+3 SET BCHR13=$GET(^BCHR(BCHR,13))
+4 IF $Y>(IOSL-5)
DO FF
IF BCHQUIT
QUIT
+5 WRITE !?3,"SUBJECTIVE INFORMATION (includes patient's complaint)",?65,"TEMP ",$PIECE(BCHR12,U,7)
+6 SET BCHDA=BCHR
SET BCHFILE=90002
SET BCHNODE=51
SET BCHIOM=58
DO WP
+7 SET BCHWP(1)=$GET(BCHWP(1))
SET $EXTRACT(BCHWP(1),62)="PULSE "_$PIECE(BCHR12,U,8)
+8 SET BCHWP(2)=$GET(BCHWP(2))
SET $EXTRACT(BCHWP(2),62)="RESP "_$PIECE(BCHR12,U,9)
+9 SET BCHWP(3)=$GET(BCHWP(3))
SET $EXTRACT(BCHWP(3),62)="BP "_$PIECE(BCHR12,U,1)
+10 SET BCHWP(4)=$GET(BCHWP(4))
SET $EXTRACT(BCHWP(4),62)="WT "_$PIECE(BCHR12,U,2)
+11 SET BCHWP(5)=$GET(BCHWP(5))
SET $EXTRACT(BCHWP(5),62)="HT "_$PIECE(BCHR12,U,3)
+12 SET BCHX1=0
FOR
SET BCHX1=$ORDER(BCHWP(BCHX1))
IF BCHX1'=+BCHX1!(BCHQUIT)
QUIT
Begin DoDot:1
+13 IF $Y>(IOSL-4)
DO FF
IF BCHQUIT
QUIT
+14 WRITE !?4,BCHWP(BCHX1)
+15 QUIT
End DoDot:1
+16 IF $Y>(IOSL-7)
DO FF
IF BCHQUIT
QUIT
OBJ ;
+1 ;IHS/TUCSON/LAB - modified to display objective info patch 1 06/03/97
+2 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+3 WRITE !?3,"OBJECTIVE DATA",?65,"HEAD ",$PIECE(BCHR12,U,4)
+4 SET BCHDA=BCHR
SET BCHFILE=90002
SET BCHNODE=61
SET BCHIOM=58
DO WP
+5 SET BCHWP(1)=$GET(BCHWP(1))
SET $EXTRACT(BCHWP(1),62)="BMI "_$PIECE(BCHR12,U,12)
+6 SET BCHWP(2)=$GET(BCHWP(2))
SET $EXTRACT(BCHWP(2),62)="WAIST "_$PIECE(BCHR12,U,11)
+7 SET BCHWP(3)=$GET(BCHWP(3))
SET $EXTRACT(BCHWP(3),62)="VU "_$PIECE(BCHR12,U,5)
+8 SET BCHWP(4)=$GET(BCHWP(4))
SET $EXTRACT(BCHWP(4),62)="VC "_$PIECE(BCHR12,U,6)
+9 SET BCHX1=0
FOR
SET BCHX1=$ORDER(BCHWP(BCHX1))
IF BCHX1'=+BCHX1!(BCHQUIT)
QUIT
Begin DoDot:1
+10 IF $Y>(IOSL-4)
DO FF
IF BCHQUIT
QUIT
+11 WRITE !?4,BCHWP(BCHX1)
+12 QUIT
End DoDot:1
+13 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
POV ;
+1 IF $Y>(IOSL-6)
DO FF
IF BCHQUIT
QUIT
+2 WRITE !?3,"ASSESSMENT - PCC Purpose of Visit"
+3 ;,?60,"Sub"
WRITE !?3,"Hlth Prob",?13,"Svc",?18,"Svc",?30,"Narrative"
+4 WRITE !?5,"Code",?13,"Code",?18,"Mins",?65,"Tests"
+5 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+6 SET (BCHX,BCHC)=0
FOR
SET BCHX=$ORDER(^BCHRPROB("AD",BCHR,BCHX))
IF BCHX'=+BCHX!(BCHQUIT)
QUIT
SET BCHC=BCHC+1
Begin DoDot:1
+7 IF $Y>(IOSL-5)
DO FF
IF BCHQUIT
QUIT
+8 SET BCHRNODE=^BCHRPROB(BCHX,0)
+9 WRITE !?6,$PIECE(^BCHTPROB($PIECE(BCHRNODE,U),0),U,2)
+10 WRITE ?14,$SELECT($PIECE(BCHRNODE,U,4)]"":$PIECE(^BCHTSERV($PIECE(BCHRNODE,U,4),0),U,3),1:"??")
+11 WRITE ?19,$PIECE(^BCHRPROB(BCHX,0),U,5)
+12 ;IHS/TUCSON/LAB - patch 2
SET BCHTNRQ=$PIECE(^BCHRPROB(BCHX,0),U,6)
SET BCHTNRQ=$SELECT(BCHTNRQ]"":$PIECE(^AUTNPOV(BCHTNRQ,0),U),1:"<<none>>")
SET BCHW=35
DO WRT
+13 WRITE ?23,BCHRPRNM(1)
IF BCHC=1
WRITE ?65,"PPD ",$PIECE(BCHR12,U,10)
+14 ;begin Y2K
+15 ;W ! W:$D(BCHRPRNM(2)) ?23,BCHRPRNM(2) W:BCHC=1 ?65,"BS ",$S($P(BCHR13,U,2)]"":$P(BCHR13,U,2),$P(BCHR13,U)]"":$E($P(BCHR13,U),4,5)_"/"_$E($P(BCHR13,U),6,7)_"/"_$E($P(BCHR13,U),2,3),1:"") ;Y2000
+16 ;Y2000
WRITE !
IF $DATA(BCHRPRNM(2))
WRITE ?23,BCHRPRNM(2)
IF BCHC=1
WRITE ?65,"BG ",$SELECT($PIECE(BCHR13,U,2)]"":$PIECE(BCHR13,U,2),$PIECE(BCHR13,U)]"":$EXTRACT($PIECE(BCHR0,U),4,5)_"/"_$EXTRACT($PIECE(BCHR0,U),6,7)_"/"_(1700+($EXTRACT($PIECE(BCHR0,U),1,3))),1:"")
+17 ;W ! W:$D(BCHRPRNM(3)) ?23,BCHRPRNM(3) W:BCHC=1 ?65,"T/C ",$S($P(BCHR13,U,4)]"":$P(BCHR13,U,4),$P(BCHR13,U,3)]"":$E($P(BCHR13,U,3),4,5)_"/"_$E($P(BCHR13,U,3),6,7)_"/"_$E($P(BCHR13,U,3),2,3),1:"") ;Y2000
+18 ;W ! W:$D(BCHRPRNM(3)) ?23,BCHRPRNM(3) W:BCHC=1 ?65,"T/C ",$S($P(BCHR13,U,4)]"":$P(BCHR13,U,4),$P(BCHR13,U,3)]"":$E($P(BCHR13,U,3),4,5)_"/"_$E($P(BCHR13,U,3),6,7)_"/"_(1700+($E($P(BCHR13,U,3),1,3))),1:"") ;Y2000
+19 WRITE !
IF $DATA(BCHRPRNM(4))
WRITE ?23,BCHRPRNM(4)
IF BCHC=1
WRITE ?58,"Hemoglobin A1c ",$SELECT($PIECE(BCHR13,U,9)]"":$PIECE(BCHR13,U,9),1:"")
+20 ;W ! W:$D(BCHRPRNM(5)) ?23,BCHRPRNM(5) W:BCHC=1 ?58,"Total Cholesterol ",$S($P(BCHR13,U,10)]"":$P(BCHR13,U,10),1:"")
+21 ;end Y2K
+22 QUIT
End DoDot:1
+23 SET BCHX1=3
FOR
SET BCHX1=$ORDER(BCHRPRNM(BCHX1))
IF BCHX1'=+BCHX1!(BCHQUIT)
QUIT
IF $Y>(IOSL-4)
DO FF
IF BCHQUIT
QUIT
WRITE !?23,BCHRPRNM(BCHX1)
+24 KILL BCHRPRNM,BCHX1
+25 IF BCHQUIT
QUIT
PLANS ;
+1 ;IHS/TUCSON/LAB - modified to display plan info patch 1 06/03/97
+2 IF $Y>(IOSL-7)
DO FF
IF BCHQUIT
QUIT
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+4 WRITE !?3,"Plans/Treatments"
+5 ;begin Y2K
+6 ;W ?65,"HCT ",$S($P(BCHR13,U,8)]"":$P(BCHR13,U,8),$P(BCHR13,U,7)]"":$E($P(BCHR13,U,7),4,5)_"/"_$E($P(BCHR13,U,7),6,7)_"/"_$E($P(BCHR13,U,7),2,3),1:"") ;Y2000
+7 ;Y2000
WRITE ?65,"HCT ",$SELECT($PIECE(BCHR13,U,8)]"":$PIECE(BCHR13,U,8),$PIECE(BCHR13,U,7)]"":$EXTRACT($PIECE(BCHR13,U,7),4,5)_"/"_$EXTRACT($PIECE(BCHR13,U,7),6,7)_"/"_(1700+($EXTRACT($PIECE(BCHR13,U,7),1,3))),1:"")
+8 ;end Y2K
+9 SET BCHDA=BCHR
SET BCHFILE=90002
SET BCHNODE=71
SET BCHIOM=52
DO WP
+10 ;W !?65,"UA ",$S($P(BCHR13,U,8)]"":$P(BCHR13,U,8),$P(BCHR13,U,7)]"":$E($P(BCHR13,U,7),4,5)_"/"_$E($P(BCHR13,U,7),6,7)_"/"_$E($P(BCHR13,U,7),2,3),1:"")
+11 ;begin Y2K
+12 ;S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="UA "_$S($P(BCHR13,U,6)]"":$P(BCHR13,U,6),$P(BCHR13,U,5)]"":$E($P(BCHR13,U,5),4,5)_"/"_$E($P(BCHR13,U,5),6,7)_"/"_$E($P(BCHR13,U,5),2,3),1:"") ;Y2000
+13 ;S BCHWP(1)=$G(BCHWP(1)),$E(BCHWP(1),62)="UA "_$S($P(BCHR13,U,6)]"":$P(BCHR13,U,6),$P(BCHR13,U,5)]"":$E($P(BCHR13,U,5),4,5)_"/"_$E($P(BCHR13,U,5),6,7)_"/"_(1700+($E($P(BCHR13,U,5),1,3))),1:"")
+14 ;end Y2K
+15 SET BCHWP(2)=$GET(BCHWP(2))
SET $EXTRACT(BCHWP(2),55)="Reproductive Factors"
+16 ;begin Y2K
+17 ;S BCHWP(3)=$G(BCHWP(3)),$E(BCHWP(3),55)="LMP " S:$P(BCHR0,U,13)]"" BCHWP(3)=BCHWP(3)_$E($P(BCHR0,U,13),4,5)_"/"_$E($P(BCHR0,U,13),6,7)_"/"_$E($P(BCHR0,U,13),2,3) ;Y2000
+18 ;Y2000
SET BCHWP(3)=$GET(BCHWP(3))
SET $EXTRACT(BCHWP(3),55)="LMP "
IF $PIECE(BCHR0,U,13)]""
SET BCHWP(3)=BCHWP(3)_$EXTRACT($PIECE(BCHR0,U,13),4,5)_"/"_$EXTRACT($PIECE(BCHR0,U,13),6,7)_"/"_(1700+($EXTRACT($PIECE(BCHR0,U,13),1,3)))
+19 ;end Y2K
+20 SET BCHWP(4)=$GET(BCHWP(4))
SET $EXTRACT(BCHWP(4),55)="FP "_$SELECT($PIECE(BCHR0,U,14)]"":$PIECE(^BCHTFPM($PIECE(BCHR0,U,14),0),U),1:"")
+21 SET BCHX1=0
FOR
SET BCHX1=$ORDER(BCHWP(BCHX1))
IF BCHX1'=+BCHX1!(BCHQUIT)
QUIT
Begin DoDot:1
+22 IF $Y>(IOSL-4)
DO FF
IF BCHQUIT
QUIT
+23 WRITE !?4,BCHWP(BCHX1)
+24 QUIT
End DoDot:1
+25 IF $Y>(IOSL-3)
DO FF
IF BCHQUIT
QUIT
+26 ;W !?3,"Education Topics recorded"
+27 ;S BCHX=0 F S BCHX=$O(^BCHRPED("AD",BCHR,BCHX)) Q:BCHX'=+BCHX D
+28 ;.W !?3,$E($$VAL^XBDIQ1(90002.02,BCHX,.01),1,38),?40,$E($$VAL^XBDIQ1(90002.02,BCHX,.06),1,10),?51,$E($$VAL^XBDIQ1(90002.02,BCHX,.07),1,10),?62,$$VAL^XBDIQ1(90002.02,BCHX,.08)_" MIN",?69,"OBJ: ",$$VAL^XBDIQ1(90002.02,BCHX,.14)
+29 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
ACT ;
+1 IF $Y>(IOSL-5)
DO FF
IF BCHQUIT
QUIT
+2 WRITE !?3,"Activity Location: ",$SELECT($PIECE(BCHR0,U,6)]"":$PIECE(^BCHTACTL($PIECE(BCHR0,U,6),0),U),1:"")
IF $PIECE(BCHR0,U,5)]""
WRITE ?40,"Hospital/Clinic: ",$EXTRACT($PIECE(^DIC(4,$PIECE(BCHR0,U,5),0),U),1,22)
+3 ;table both and print 1,2,3,etc
+4 NEW BCHREFB,BCHREFT,C
+5 SET X=0
SET C=0
FOR
SET X=$ORDER(^BCHR(BCHR,41,X))
IF X'=+X
QUIT
SET C=C+1
SET BCHREFB(C)=$PIECE(^BCHTREF($PIECE(^BCHR(BCHR,41,X,0),U),0),U,1)
+6 SET X=0
SET C=0
FOR
SET X=$ORDER(^BCHR(BCHR,42,X))
IF X'=+X
QUIT
SET C=C+1
SET BCHREFT(C)=$PIECE(^BCHTREF($PIECE(^BCHR(BCHR,42,X,0),U),0),U,1)
+7 WRITE !?3,"Referred to CHR by: ",?45,"Referred by CHR to: "
+8 FOR X=1:1:20
IF $DATA(BCHREFB(X))!($DATA(BCHREFT(X)))
Begin DoDot:1
+9 WRITE !?5,$GET(BCHREFB(X)),?48,$GET(BCHREFT(X))
End DoDot:1
+10 WRITE !?3,"Travel Time: ",$PIECE(BCHR0,U,11),?45,"Number Served: ",$PIECE(BCHR0,U,12)
+11 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_"),!
DEMO ;demographics
+1 DO DEMO^BCHUFP
+2 QUIT
WRT ;EP - Entry point to print wp fields pass node in BCHNODE
+1 KILL ^UTILITY($JOB,"W"),BCHRPRNM
+2 SET BCHPCNT=0
+3 SET DIWL=1
SET DIWR=35
SET X=BCHTNRQ
DO ^DIWP
+4 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
SET BCHPCNT=BCHPCNT+1
SET BCHRPRNM(BCHPCNT)=^UTILITY($JOB,"W",DIWL,Z,0)
+5 KILL DIWL,DIWR,DIWF,Z
+6 KILL ^UTILITY($JOB,"W"),BCHNODE,BCHFILE,BCHDA
+7 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 BCHQUIT=1
QUIT
+2 IF $DATA(IOF)
WRITE @IOF
+3 QUIT
WP ;EP - Entry point to print wp fields pass node in BCHWP
+1 ;PASS FILE IN BCHFILE, ENTRY IN BCHDA
+2 NEW G,P,BCHX
+3 KILL BCHWP
+4 KILL ^UTILITY($JOB,"W")
+5 SET BCHX=0
SET P=0
+6 SET G=$SELECT($GET(G)]"":G,1:^DIC(BCHFILE,0,"GL"))
SET G=G_BCHDA_","_BCHNODE_",BCHX)"
+7 SET DIWR=$SELECT($GET(BCHIOM):BCHIOM,1:IOM)
SET DIWL=0
FOR
SET BCHX=$ORDER(@G)
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+8 SET Y=$PIECE(G,")")_",0)"
+9 SET X=""
IF $GET(BCHCAP)]""
IF BCHX=1
SET X=BCHCAP
+10 SET X=X_@Y
DO ^DIWP
+11 QUIT
End DoDot:1
WPS ;EP
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
SET P=P+1
SET BCHWP(P)=^UTILITY($JOB,"W",DIWL,Z,0)
+2 KILL DIWL,DIWR,DIWF,Z
+3 KILL ^UTILITY($JOB,"W"),BCHNODE,BCHFILE,BCHDA,G,BCHCOL,BCHCAP
+4 QUIT
