- 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
