BHSBCH ;IHS/CIA/MGH - Health Summary for CHR component ;17-Mar-2006 10:36;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
;===================================================================
;Taken from BCHDHS
; IHS/TUCSON/LAB - CHR HEALTH SUMMARY COMPONENT ;09-Nov-2004 15:39;MGH
;;1.0;IHS RPMS CHR SYSTEM;**2,11,12,14**;OCT 28, 1996
;
;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
D CKP^GMTSUP Q:$D(GMTSQIT)
OUTPT ; ********** CHR PROBLEM CODES AND DESIGNATED PROVIDER
; <SETUP>
I '$D(^BCHR("AE",BHSPAT)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,"No CHR Records on File.",! Q
; <DISPLAY>
S BCHSPVD=0
F BCHSIVD=0:0 S BCHSIVD=$O(^BCHR("AE",BHSPAT,BCHSIVD)) Q:BCHSIVD=""!(BCHSIVD>GMTSDLM) D
.D ONEDATE Q:$D(GMTSQIT) S:(BCHSDAT'=BCHSPVD)&BCHSDTU GMTSNDM=GMTSNDM-BCHSDTU,BCHSPVD=BCHSDAT Q:GMTSNDM=0
OUTPTX K BCHSIVD,BCHX,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,I,J,D0,BHSICL,BHSNRQ,BHSTXT
Q
ONEDATE S X=-BCHSIVD\1+9999999 D REGDT4^GMTSU S BCHSDAT=X S BCHSPFN="",BCHSDTU=0,BCHSNDT=(BCHSDAT'=BCHSPVD)
S BCHSVDF="" F BCHSQ=0:0 S BCHSVDF=$O(^BCHR("AE",BHSPAT,BCHSIVD,BCHSVDF)) Q:BCHSVDF="" D
.S BCHSN=^BCHR(BCHSVDF,0) D GETSITE,DSPVIS Q:$D(GMTSQIT)
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 ;
N X,Y,C,Z
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
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
N BCHF F BCHF=1301:1:1308 S BCHX=$$VAL^XBDIQ1(90002,BCHSVDF,BCHF) I BCHX]"" D
.D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG 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
;IHS/TUCSON/LAB - patch 2 - 06/03/97 - fixed referral display
I $P(BCHSN,U,7)="",$P(BCHSN,U,8)="" W ! Q
W ?25,"Referred BY: ",$E($S($P(BCHSN,U,7)]"":$P(^BCHTREF($P(BCHSN,U,7),0),U),1:""),1,11)
W ?50,"Referred TO: ",$E($S($P(BCHSN,U,8):$P(^BCHTREF($P(BCHSN,U,8),0),U),1:""),1,12),!
Q
;
NOPOV ;
S BHSTXT="",(BCHSICD,BHSNRQ)="<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 BHSTXT=""
D COMMON
Q
COMMON ;
D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG BCHSNDT=1
I BCHSNDT W BCHSDAT S BCHSPFN="",BCHSNDT=0
W ?9,BCHSFAC,?20,$$PPINI^BCHUTIL(BCHSVDF) S BHSICL=25,BHSNRQ=BCHSICD D PRTTXT^BHSUTL
S BHSTXT="",BHSICL=25,BHSNRQ=BCHSNRQ D PRTTXT^BHSUTL
Q
BHSBCH ;IHS/CIA/MGH - Health Summary for CHR component ;17-Mar-2006 10:36;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
+2 ;===================================================================
+3 ;Taken from BCHDHS
+4 ; IHS/TUCSON/LAB - CHR HEALTH SUMMARY COMPONENT ;09-Nov-2004 15:39;MGH
+5 ;;1.0;IHS RPMS CHR SYSTEM;**2,11,12,14**;OCT 28, 1996
+6 ;
+7 ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - fixed the display of referral data
+8 ;Called from health summary component called CHR.
+9 ;Extracts and writes information on the health summary from the
+10 ;CHR data file.
+11 ;
CHR ;EP called from health summary
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
OUTPT ; ********** CHR PROBLEM CODES AND DESIGNATED PROVIDER
+1 ; <SETUP>
+2 IF '$DATA(^BCHR("AE",BHSPAT))
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !,"No CHR Records on File.",!
QUIT
+3 ; <DISPLAY>
+4 SET BCHSPVD=0
+5 FOR BCHSIVD=0:0
SET BCHSIVD=$ORDER(^BCHR("AE",BHSPAT,BCHSIVD))
IF BCHSIVD=""!(BCHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+6 DO ONEDATE
IF $DATA(GMTSQIT)
QUIT
IF (BCHSDAT'=BCHSPVD)&BCHSDTU
SET GMTSNDM=GMTSNDM-BCHSDTU
SET BCHSPVD=BCHSDAT
IF GMTSNDM=0
QUIT
End DoDot:1
OUTPTX KILL BCHSIVD,BCHX,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,I,J,D0,BHSICL,BHSNRQ,BHSTXT
+2 QUIT
ONEDATE SET X=-BCHSIVD\1+9999999
DO REGDT4^GMTSU
SET BCHSDAT=X
SET BCHSPFN=""
SET BCHSDTU=0
SET BCHSNDT=(BCHSDAT'=BCHSPVD)
+1 SET BCHSVDF=""
FOR BCHSQ=0:0
SET BCHSVDF=$ORDER(^BCHR("AE",BHSPAT,BCHSIVD,BCHSVDF))
IF BCHSVDF=""
QUIT
Begin DoDot:1
+2 SET BCHSN=^BCHR(BCHSVDF,0)
DO GETSITE
DO DSPVIS
IF $DATA(GMTSQIT)
QUIT
End DoDot:1
+3 QUIT
+4 ;
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 NEW X,Y,C,Z
+2 SET BCHSDTU=1
+3 IF $ORDER(^BCHRPROB("AD",BCHSVDF,""))=""
DO NOPOV
QUIT
+4 SET BCHSPDN=""
FOR BCHSQ=0:0
SET BCHSPDN=$ORDER(^BCHRPROB("AD",BCHSVDF,BCHSPDN))
IF 'BCHSPDN
QUIT
SET BCHSR=^BCHRPROB(BCHSPDN,0)
DO HASPOV
+5 ;display measurements
+6 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)
+7 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
+8 NEW BCHF
FOR BCHF=1301:1:1308
SET BCHX=$$VAL^XBDIQ1(90002,BCHSVDF,BCHF)
IF BCHX]""
Begin DoDot:1
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET BCHSNDT=1
+10 IF BCHSNDT
WRITE BCHSDAT
SET BCHSPFN=""
SET BCHSNDT=0
+11 WRITE !?25,$PIECE(^DD(90002,BCHF,0),U),?55,BCHX
+12 QUIT
End DoDot:1
+13 ;IHS/TUCSON/LAB - patch 2
IF $PIECE(BCHSN,U,9)]""
WRITE !?25,"Evaluation: ",$$EXTSET^XBFUNC(90002,.09,$PIECE(BCHSN,U,9)),!
+14 ;IHS/TUCSON/LAB - patch 2 - 06/03/97 - fixed referral display
+15 IF $PIECE(BCHSN,U,7)=""
IF $PIECE(BCHSN,U,8)=""
WRITE !
QUIT
+16 WRITE ?25,"Referred BY: ",$EXTRACT($SELECT($PIECE(BCHSN,U,7)]"":$PIECE(^BCHTREF($PIECE(BCHSN,U,7),0),U),1:""),1,11)
+17 WRITE ?50,"Referred TO: ",$EXTRACT($SELECT($PIECE(BCHSN,U,8):$PIECE(^BCHTREF($PIECE(BCHSN,U,8),0),U),1:""),1,12),!
+18 QUIT
+19 ;
NOPOV ;
+1 SET BHSTXT=""
SET (BCHSICD,BHSNRQ)="<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 BHSTXT=""
+4 DO COMMON
+5 QUIT
COMMON ;
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET BCHSNDT=1
+2 IF BCHSNDT
WRITE BCHSDAT
SET BCHSPFN=""
SET BCHSNDT=0
+3 WRITE ?9,BCHSFAC,?20,$$PPINI^BCHUTIL(BCHSVDF)
SET BHSICL=25
SET BHSNRQ=BCHSICD
DO PRTTXT^BHSUTL
+4 SET BHSTXT=""
SET BHSICL=25
SET BHSNRQ=BCHSNRQ
DO PRTTXT^BHSUTL
+5 QUIT
