- 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
