- 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
