BCHDHS ; IHS/CMI/LAB - CHR HEALTH SUMMARY COMPONENT ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
;IHS/TUCSON/LAB - patch 2 - 06/03/97 - fixed the display of referral data
;Called from health summary component called CHR.
;Extracts and writes information on the health summary from the
;CHR data file.
;
CHR ;EP called from health summary
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
OUTPT ; ********** CHR PROBLEM CODES AND DESIGNATED PROVIDER
; <SETUP>
I '$D(^BCHR("AE",APCHSPAT)) X APCHSCKP Q:$D(APCHSQIT) W !,"No CHR Records on File.",! Q
; <DISPLAY>
S BCHSPVD=0
F BCHSIVD=0:0 S BCHSIVD=$O(^BCHR("AE",APCHSPAT,BCHSIVD)) Q:BCHSIVD=""!(BCHSIVD>APCHSDLM) D ONEDATE Q:$D(APCHSQIT) S:(BCHSDAT'=BCHSPVD)&BCHSDTU APCHSNDM=APCHSNDM-BCHSDTU,BCHSPVD=BCHSDAT Q:APCHSNDM=0
OUTPTX K BCHSIVD,BCHSDTU,BCHSVDF,BCHSFAC,BCHSPFN,BCHSMTX,BCHSPVD,BCHSOVT,BCHSNDT,BCHSCLI,BCHSPDN,BCHSICD,BCHSICL,BCHSDAT,BCHSN,BCHSQ,BCHSR,BCHSX,BCHS,BCHACTL,BCHSNRQ
K BCHSNFL,BCHSNSH,BCHSNAB,BCHSVSC,BCHSFAC,Y,D0
Q
ONEDATE S Y=-BCHSIVD\1+9999999 X APCHSCVD S BCHSDAT=Y S BCHSPFN="",BCHSDTU=0,BCHSNDT=(BCHSDAT'=BCHSPVD)
S BCHSVDF="" F BCHSQ=0:0 S BCHSVDF=$O(^BCHR("AE",APCHSPAT,BCHSIVD,BCHSVDF)) Q:BCHSVDF="" S BCHSN=^BCHR(BCHSVDF,0) D GETSITE,DSPVIS Q:$D(APCHSQIT)
Q
;
GETSITE ;
S BCHACTL=$P(BCHSN,U,6) I BCHACTL]"" S BCHACTL=$E($P(^BCHTACTL(BCHACTL,0),U),1,10)
S BCHSFAC=$P(BCHSN,U,5) I BCHSFAC]"" S BCHSFAC=$P(^AUTTLOC(BCHSFAC,0),U,2)
I BCHSFAC="" S BCHSFAC=BCHACTL
Q
DSPVIS ;
S BCHSDTU=1
I $O(^BCHRPROB("AD",BCHSVDF,""))="" D NOPOV Q
S BCHSPDN="" F BCHSQ=0:0 S BCHSPDN=$O(^BCHRPROB("AD",BCHSVDF,BCHSPDN)) Q:'BCHSPDN S BCHSR=^BCHRPROB(BCHSPDN,0) D HASPOV
;display measurements
K X N Z S Y=$G(^BCHR(BCHSVDF,12)) I Y]"" S Z="BP^WT^HT^HC^VU^VC^TMP^PU^RESP^PPD",C=0 F I=1:1:10 I $P(Y,U,I)]"" S C=C+1,X(C)=$P(Z,U,I)_"^"_$P(Y,U,I)
I $D(X) S I=0,J=25,C=0 F S I=$O(X(I)) Q:I'=+I S C=C+1 W:C=1 ! W ?J,$P(X(I),U)," ",$P(X(I),U,2) S J=J+18 S:C=3 C=0,J=25
NEW BCHF F BCHF=1301:1:1308 S BCHX=$$VAL^XBDIQ1(90002,BCHSVDF,BCHF) I BCHX]"" D
.X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG BCHSNDT=1
.I BCHSNDT W BCHSDAT S BCHSPFN="",BCHSNDT=0
.W !?25,$P(^DD(90002,BCHF,0),U),?55,BCHX
.Q
I $P(BCHSN,U,9)]"" W !?25,"Evaluation: ",$$EXTSET^XBFUNC(90002,.09,$P(BCHSN,U,9)),! ;IHS/TUCSON/LAB - patch 2
NEW BCHREFB,BCHREFT,C
S X=0,C=0 F S X=$O(^BCHR(BCHSVDF,41,X)) Q:X'=+X S C=C+1,BCHREFB(C)=$P(^BCHTREF($P(^BCHR(BCHSVDF,41,X,0),U),0),U,1)
S X=0,C=0 F S X=$O(^BCHR(BCHSVDF,42,X)) Q:X'=+X S C=C+1,BCHREFT(C)=$P(^BCHTREF($P(^BCHR(BCHSVDF,42,X,0),U),0),U,1)
W !?5,"Referred to CHR by: ",?45,"Referred by CHR to: "
F X=1:1:20 I $D(BCHREFB(X))!($D(BCHREFT(X))) Q:$D(APCHSQIT) D
.X APCHSCKP Q:$D(APCHSQIT)
.W !?5,$G(BCHREFB(X)),?45,$G(BCHREFT(X))
W !!
Q
;
NOPOV ;
S APCHSTXT="",(BCHSICD,APCHSNRQ)="<CHR POV's not yet entered>"
G COMMON
;
HASPOV ;
S BCHSICD=$E($P(^BCHTPROB($P(BCHSR,U),0),U),1,20)_" ("_$P(^BCHTPROB($P(BCHSR,U),0),U,2)_") - "
S BCHSICD=BCHSICD_$S($P(BCHSR,U,4):$E($P(^BCHTSERV($P(BCHSR,U,4),0),U),1,20),1:"??service")_" AT: "_$P(BCHSR,U,5)_$S($P(BCHSR,U,7):" - S/R",1:"")
S BCHSNRQ=$P(BCHSR,U,6) S:BCHSNRQ BCHSNRQ=$P(^AUTNPOV(BCHSNRQ,0),U) S APCHSTXT=""
D COMMON
Q
COMMON ;
X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG BCHSNDT=1
I BCHSNDT W BCHSDAT S BCHSPFN="",BCHSNDT=0
W ?9,BCHSFAC,?20,$$PPINI^BCHUTIL(BCHSVDF) S APCHSICL=25,APCHSNRQ=BCHSICD D PRTTXT^APCHSUTL
S APCHSTXT="",APCHSICL=25,APCHSNRQ=BCHSNRQ D PRTTXT^APCHSUTL
Q
BCHDHS ; IHS/CMI/LAB - CHR HEALTH SUMMARY COMPONENT ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - fixed the display of referral data
+4 ;Called from health summary component called CHR.
+5 ;Extracts and writes information on the health summary from the
+6 ;CHR data file.
+7 ;
CHR ;EP called from health summary
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
OUTPT ; ********** CHR PROBLEM CODES AND DESIGNATED PROVIDER
+1 ; <SETUP>
+2 IF '$DATA(^BCHR("AE",APCHSPAT))
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,"No CHR Records on File.",!
QUIT
+3 ; <DISPLAY>
+4 SET BCHSPVD=0
+5 FOR BCHSIVD=0:0
SET BCHSIVD=$ORDER(^BCHR("AE",APCHSPAT,BCHSIVD))
IF BCHSIVD=""!(BCHSIVD>APCHSDLM)
QUIT
DO ONEDATE
IF $DATA(APCHSQIT)
QUIT
IF (BCHSDAT'=BCHSPVD)&BCHSDTU
SET APCHSNDM=APCHSNDM-BCHSDTU
SET BCHSPVD=BCHSDAT
IF APCHSNDM=0
QUIT
OUTPTX KILL BCHSIVD,BCHSDTU,BCHSVDF,BCHSFAC,BCHSPFN,BCHSMTX,BCHSPVD,BCHSOVT,BCHSNDT,BCHSCLI,BCHSPDN,BCHSICD,BCHSICL,BCHSDAT,BCHSN,BCHSQ,BCHSR,BCHSX,BCHS,BCHACTL,BCHSNRQ
+1 KILL BCHSNFL,BCHSNSH,BCHSNAB,BCHSVSC,BCHSFAC,Y,D0
+2 QUIT
ONEDATE SET Y=-BCHSIVD\1+9999999
XECUTE APCHSCVD
SET BCHSDAT=Y
SET BCHSPFN=""
SET BCHSDTU=0
SET BCHSNDT=(BCHSDAT'=BCHSPVD)
+1 SET BCHSVDF=""
FOR BCHSQ=0:0
SET BCHSVDF=$ORDER(^BCHR("AE",APCHSPAT,BCHSIVD,BCHSVDF))
IF BCHSVDF=""
QUIT
SET BCHSN=^BCHR(BCHSVDF,0)
DO GETSITE
DO DSPVIS
IF $DATA(APCHSQIT)
QUIT
+2 QUIT
+3 ;
GETSITE ;
+1 SET BCHACTL=$PIECE(BCHSN,U,6)
IF BCHACTL]""
SET BCHACTL=$EXTRACT($PIECE(^BCHTACTL(BCHACTL,0),U),1,10)
+2 SET BCHSFAC=$PIECE(BCHSN,U,5)
IF BCHSFAC]""
SET BCHSFAC=$PIECE(^AUTTLOC(BCHSFAC,0),U,2)
+3 IF BCHSFAC=""
SET BCHSFAC=BCHACTL
+4 QUIT
DSPVIS ;
+1 SET BCHSDTU=1
+2 IF $ORDER(^BCHRPROB("AD",BCHSVDF,""))=""
DO NOPOV
QUIT
+3 SET BCHSPDN=""
FOR BCHSQ=0:0
SET BCHSPDN=$ORDER(^BCHRPROB("AD",BCHSVDF,BCHSPDN))
IF 'BCHSPDN
QUIT
SET BCHSR=^BCHRPROB(BCHSPDN,0)
DO HASPOV
+4 ;display measurements
+5 KILL X
NEW Z
SET Y=$GET(^BCHR(BCHSVDF,12))
IF Y]""
SET Z="BP^WT^HT^HC^VU^VC^TMP^PU^RESP^PPD"
SET C=0
FOR I=1:1:10
IF $PIECE(Y,U,I)]""
SET C=C+1
SET X(C)=$PIECE(Z,U,I)_"^"_$PIECE(Y,U,I)
+6 IF $DATA(X)
SET I=0
SET J=25
SET C=0
FOR
SET I=$ORDER(X(I))
IF I'=+I
QUIT
SET C=C+1
IF C=1
WRITE !
WRITE ?J,$PIECE(X(I),U)," ",$PIECE(X(I),U,2)
SET J=J+18
IF C=3
SET C=0
SET J=25
+7 NEW BCHF
FOR BCHF=1301:1:1308
SET BCHX=$$VAL^XBDIQ1(90002,BCHSVDF,BCHF)
IF BCHX]""
Begin DoDot:1
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
SET BCHSNDT=1
+9 IF BCHSNDT
WRITE BCHSDAT
SET BCHSPFN=""
SET BCHSNDT=0
+10 WRITE !?25,$PIECE(^DD(90002,BCHF,0),U),?55,BCHX
+11 QUIT
End DoDot:1
+12 ;IHS/TUCSON/LAB - patch 2
IF $PIECE(BCHSN,U,9)]""
WRITE !?25,"Evaluation: ",$$EXTSET^XBFUNC(90002,.09,$PIECE(BCHSN,U,9)),!
+13 NEW BCHREFB,BCHREFT,C
+14 SET X=0
SET C=0
FOR
SET X=$ORDER(^BCHR(BCHSVDF,41,X))
IF X'=+X
QUIT
SET C=C+1
SET BCHREFB(C)=$PIECE(^BCHTREF($PIECE(^BCHR(BCHSVDF,41,X,0),U),0),U,1)
+15 SET X=0
SET C=0
FOR
SET X=$ORDER(^BCHR(BCHSVDF,42,X))
IF X'=+X
QUIT
SET C=C+1
SET BCHREFT(C)=$PIECE(^BCHTREF($PIECE(^BCHR(BCHSVDF,42,X,0),U),0),U,1)
+16 WRITE !?5,"Referred to CHR by: ",?45,"Referred by CHR to: "
+17 FOR X=1:1:20
IF $DATA(BCHREFB(X))!($DATA(BCHREFT(X)))
IF $DATA(APCHSQIT)
QUIT
Begin DoDot:1
+18 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+19 WRITE !?5,$GET(BCHREFB(X)),?45,$GET(BCHREFT(X))
End DoDot:1
+20 WRITE !!
+21 QUIT
+22 ;
NOPOV ;
+1 SET APCHSTXT=""
SET (BCHSICD,APCHSNRQ)="<CHR POV's not yet entered>"
+2 GOTO COMMON
+3 ;
HASPOV ;
+1 SET BCHSICD=$EXTRACT($PIECE(^BCHTPROB($PIECE(BCHSR,U),0),U),1,20)_" ("_$PIECE(^BCHTPROB($PIECE(BCHSR,U),0),U,2)_") - "
+2 SET BCHSICD=BCHSICD_$SELECT($PIECE(BCHSR,U,4):$EXTRACT($PIECE(^BCHTSERV($PIECE(BCHSR,U,4),0),U),1,20),1:"??service")_" AT: "_$PIECE(BCHSR,U,5)_$SELECT($PIECE(BCHSR,U,7):" - S/R",1:"")
+3 SET BCHSNRQ=$PIECE(BCHSR,U,6)
IF BCHSNRQ
SET BCHSNRQ=$PIECE(^AUTNPOV(BCHSNRQ,0),U)
SET APCHSTXT=""
+4 DO COMMON
+5 QUIT
COMMON ;
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
SET BCHSNDT=1
+2 IF BCHSNDT
WRITE BCHSDAT
SET BCHSPFN=""
SET BCHSNDT=0
+3 WRITE ?9,BCHSFAC,?20,$$PPINI^BCHUTIL(BCHSVDF)
SET APCHSICL=25
SET APCHSNRQ=BCHSICD
DO PRTTXT^APCHSUTL
+4 SET APCHSTXT=""
SET APCHSICL=25
SET APCHSNRQ=BCHSNRQ
DO PRTTXT^APCHSUTL
+5 QUIT
