- BCHDHS1 ; IHS/CMI/LAB - CHR HEALTH SUMMARY COMPONENT PART 2 ;
- ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
- ;IHS/CMI/LAB - Y2K
- ;
- ;CMI/TUCSON/LAB - patch 5 6/22/98 - modified reference to BCHPROB to BCHTPROB
- ;
- ;Continuation of BCHDHS
- ;
- PROB ;EP
- X APCHSCKP Q:$D(APCHSQIT) S X="<<< CHR ACTIVE PROBLEMS >>>",BCHS="",$P(BCHS," ",IOM-1-$L(X)/2)="" W !,BCHS,X,BCHS,!
- ;begin Y2K
- ;S BCHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,1,3)" ;Y2000
- S BCHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+($E(Y,1,3))" ;Y2000
- ;end Y2K
- S BCHTTAT="A" D COMMON
- X APCHSCKP Q:$D(APCHSQIT) S X="<<< CHR INACTIVE PROBLEMS >>> ",BCHS="",$P(BCHS," ",IOM-1-$L(X)/2)="" W !,BCHS,X,BCHS,!
- S BCHTTAT="I" D COMMON
- K BCHTCVD,BCHTQ,Y,BCHHS,BCHPTP
- D PROBX
- Q
- COMMON ;
- K BCHTDFT S BCHTNDF=0
- S BCHTPRB="" F BCHTQ=0:0 S BCHTPRB=$O(^BCHPPROB("AA",APCHSPAT,BCHTPRB)) Q:BCHTPRB="" S BCHTDFN=$O(^(BCHTPRB,"")) S:$P(^BCHPPROB(BCHTDFN,0),U,12)=BCHTTAT BCHTNDF=BCHTNDF+1,BCHTDFT(BCHTPRB)=BCHTDFN
- I BCHTNDF=0 X APCHSCKP Q:$D(APCHSQIT) S X=" <NONE> ",BCHS="",$P(BCHS," ",IOM-1-$L(X)/2)="" W BCHS,X,BCHS,!
- ;X APCHSCKP Q:$D(APCHSQIT) W !!,"***** ",$S(BCHTTAT="A":" ACTIVE ",1:" INACTIVE "),"PROBLEMS AND TREATMENT PLANS/NOTES ***** ",!!
- S BCHTFPP="" F BCHTQ=0:0 S BCHTFPP=$O(BCHTDFT(BCHTFPP)) Q:BCHTFPP="" S BCHTDFN=BCHTDFT(BCHTFPP) D PROBDSP
- PROBX K BCHTDFT,BCHTNDF,BCHTFPP,BCHTPLN,BCHTPBN,BCHTDTM,BCHTDTN,BCHTPRB,BCHTTAT,BCHTNFP,BCHTNRQ,BCHTPNM,BCHTDFN,BCHTFCN,BCHTICD,BCHTICL,BCHTILN,BCHTN,BCHTTPT
- K BCHTNFL,BCHTNSH,BCHTNAB,BCHTVSC,BCHTITE
- Q
- PROBSCH ;
- Q
- PROBDSP ;
- S BCHTN=^BCHPPROB(BCHTDFN,0)
- S BCHTNRQ=$P(BCHTN,U,5)
- D GETNARR I 1
- E S BCHTNRQ=""
- S BCHTDOO=$P(BCHTN,U,13) I BCHTDOO]"" S Y=BCHTDOO X BCHTCVD S BCHTDOO=Y
- S BCHTPNM=+$P(BCHTN,U,7)
- S Y=$P(BCHTN,U,3) X BCHTCVD S BCHTDTM=Y
- S Y=$P(BCHTN,U,8) X BCHTCVD S BCHTDTN=Y
- ;S BCHTPLN=BCHTPNM_$E(" ",1,8-$L(BCHTPNM))_BCHTDTM
- X APCHSCKP Q:$D(APCHSQIT) W !,BCHTPNM,?4,BCHTDTM S BCHTICL=14,BCHTILN=61 D PRTICD
- D NOTEDSP
- Q
- NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
- Q:'$D(^BCHPTP("AE",BCHTDFN)) ;no notes
- S BCHTNDF=0 F BCHTQ=0:0 S BCHTNDF=$O(^BCHPTP("AE",BCHTDFN,BCHTNDF)) Q:'BCHTNDF D DSPN
- Q
- DSPN ; DISPLAY SINGLE NOTE
- S X=$O(^BCHPTP("AE",BCHTDFN,BCHTNDF,"")) Q:X=""
- S BCHTN=^BCHPTP(X,0)
- S BCHTDOI=$P(BCHTN,U,5) I BCHTDOI]"" S Y=BCHTDOI X BCHTCVD S BCHTDOI=Y
- S BCHTTPT=$P(BCHTN,U,7) S BCHTTPT=$S(BCHTTPT=1:"STP",BCHTTPT=2:"LTP",1:" ")
- S BCHHS("AUTHOR")=$P(BCHTN,U,6) S BCHHS("AUTHOR")=$S(BCHHS("AUTHOR")]"":$$PROVINI^XBFUNC1($P(BCHTN,U,6)),1:"???")
- X APCHSCKP Q:$D(APCHSQIT) W ?1,BCHTPNM_"-"_$P(BCHTN,U),?7,BCHTTPT,?11,BCHTDOI,?20,BCHHS("AUTHOR")
- S APCHSNRQ=$P(BCHTN,U,4),APCHSICL=24,APCHSTXT="" D PRTTXT^APCHSUTL
- K BCHTDOI
- Q
- ;
- PRTICD ;
- S:BCHTNRQ="" BCHTNRQ="<no narrative provided>" S BCHTICD=""
- S BCHTTXT=BCHTICD D PRTTXT
- Q
- ;
- PRTTXT ; GENERALIZED TEXT PRINTER
- S BCHTDLT=1,BCHTILN=80-BCHTICL-1
- ;S BCHTNRQ="["_$E($P(^BCHTPROB($P(BCHTN,U),0),U,2),1,25)_"] "_BCHTNRQ
- S BCHTNRQ=BCHTNRQ_" ("_$P(^BCHTPROB($P(BCHTN,U),0),U)_")" ;CMI/TUCSON/LAB - PATCH 5 changed ^BCHPROB to ^BCHTPROB 6/22/98
- I BCHTDOO]"" S BCHTNRQ=BCHTNRQ_" (ONSET: "_BCHTDOO_")"
- F BCHTQ=0:0 S:BCHTNRQ]""&(($L(BCHTNRQ)+$L(BCHTTXT)+2)<255) BCHTTXT=$S(BCHTTXT]"":BCHTTXT_"; ",1:"")_BCHTNRQ,BCHTNRQ="" Q:BCHTTXT="" D PRTTXT2
- K BCHTILN,BCHTDLT,BCHTF,BCHTC,BCHTTXT,BCHTDOO
- Q
- PRTTXT2 D GETFRAG W ?BCHTICL W BCHTF,! S BCHTICL=BCHTICL+BCHTDLT,BCHTILN=BCHTILN-BCHTDLT,BCHTDLT=0
- Q
- GETFRAG I $L(BCHTTXT)<BCHTILN S BCHTF=BCHTTXT,BCHTTXT="" Q
- F BCHTC=BCHTILN:-1:1 Q:$E(BCHTTXT,BCHTC)=" "
- S BCHTF=$E(BCHTTXT,1,BCHTC-1),BCHTTXT=$E(BCHTTXT,BCHTC+1,255)
- Q
- ;
- GETNARR ;
- I BCHTNRQ]"" S BCHTNRQ=$S($D(^AUTNPOV(BCHTNRQ)):$P(^AUTNPOV(BCHTNRQ,0),U),1:"***** "_BCHTNRQ_" *****")
- E S BCHTNRQ=""
- Q
- ;
- BCHDHS1 ; IHS/CMI/LAB - CHR HEALTH SUMMARY COMPONENT PART 2 ;
- +1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
- +2 ;IHS/CMI/LAB - Y2K
- +3 ;
- +4 ;CMI/TUCSON/LAB - patch 5 6/22/98 - modified reference to BCHPROB to BCHTPROB
- +5 ;
- +6 ;Continuation of BCHDHS
- +7 ;
- PROB ;EP
- +1 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- SET X="<<< CHR ACTIVE PROBLEMS >>>"
- SET BCHS=""
- SET $PIECE(BCHS," ",IOM-1-$LENGTH(X)/2)=""
- WRITE !,BCHS,X,BCHS,!
- +2 ;begin Y2K
- +3 ;S BCHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,1,3)" ;Y2000
- +4 ;Y2000
- SET BCHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+($E(Y,1,3))"
- +5 ;end Y2K
- +6 SET BCHTTAT="A"
- DO COMMON
- +7 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- SET X="<<< CHR INACTIVE PROBLEMS >>> "
- SET BCHS=""
- SET $PIECE(BCHS," ",IOM-1-$LENGTH(X)/2)=""
- WRITE !,BCHS,X,BCHS,!
- +8 SET BCHTTAT="I"
- DO COMMON
- +9 KILL BCHTCVD,BCHTQ,Y,BCHHS,BCHPTP
- +10 DO PROBX
- +11 QUIT
- COMMON ;
- +1 KILL BCHTDFT
- SET BCHTNDF=0
- +2 SET BCHTPRB=""
- FOR BCHTQ=0:0
- SET BCHTPRB=$ORDER(^BCHPPROB("AA",APCHSPAT,BCHTPRB))
- IF BCHTPRB=""
- QUIT
- SET BCHTDFN=$ORDER(^(BCHTPRB,""))
- IF $PIECE(^BCHPPROB(BCHTDFN,0),U,12)=BCHTTAT
- SET BCHTNDF=BCHTNDF+1
- SET BCHTDFT(BCHTPRB)=BCHTDFN
- +3 IF BCHTNDF=0
- XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- SET X=" <NONE> "
- SET BCHS=""
- SET $PIECE(BCHS," ",IOM-1-$LENGTH(X)/2)=""
- WRITE BCHS,X,BCHS,!
- +4 ;X APCHSCKP Q:$D(APCHSQIT) W !!,"***** ",$S(BCHTTAT="A":" ACTIVE ",1:" INACTIVE "),"PROBLEMS AND TREATMENT PLANS/NOTES ***** ",!!
- +5 SET BCHTFPP=""
- FOR BCHTQ=0:0
- SET BCHTFPP=$ORDER(BCHTDFT(BCHTFPP))
- IF BCHTFPP=""
- QUIT
- SET BCHTDFN=BCHTDFT(BCHTFPP)
- DO PROBDSP
- PROBX KILL BCHTDFT,BCHTNDF,BCHTFPP,BCHTPLN,BCHTPBN,BCHTDTM,BCHTDTN,BCHTPRB,BCHTTAT,BCHTNFP,BCHTNRQ,BCHTPNM,BCHTDFN,BCHTFCN,BCHTICD,BCHTICL,BCHTILN,BCHTN,BCHTTPT
- +1 KILL BCHTNFL,BCHTNSH,BCHTNAB,BCHTVSC,BCHTITE
- +2 QUIT
- PROBSCH ;
- +1 QUIT
- PROBDSP ;
- +1 SET BCHTN=^BCHPPROB(BCHTDFN,0)
- +2 SET BCHTNRQ=$PIECE(BCHTN,U,5)
- +3 DO GETNARR
- IF 1
- +4 IF '$TEST
- SET BCHTNRQ=""
- +5 SET BCHTDOO=$PIECE(BCHTN,U,13)
- IF BCHTDOO]""
- SET Y=BCHTDOO
- XECUTE BCHTCVD
- SET BCHTDOO=Y
- +6 SET BCHTPNM=+$PIECE(BCHTN,U,7)
- +7 SET Y=$PIECE(BCHTN,U,3)
- XECUTE BCHTCVD
- SET BCHTDTM=Y
- +8 SET Y=$PIECE(BCHTN,U,8)
- XECUTE BCHTCVD
- SET BCHTDTN=Y
- +9 ;S BCHTPLN=BCHTPNM_$E(" ",1,8-$L(BCHTPNM))_BCHTDTM
- +10 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- WRITE !,BCHTPNM,?4,BCHTDTM
- SET BCHTICL=14
- SET BCHTILN=61
- DO PRTICD
- +11 DO NOTEDSP
- +12 QUIT
- NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
- +1 ;no notes
- IF '$DATA(^BCHPTP("AE",BCHTDFN))
- QUIT
- +2 SET BCHTNDF=0
- FOR BCHTQ=0:0
- SET BCHTNDF=$ORDER(^BCHPTP("AE",BCHTDFN,BCHTNDF))
- IF 'BCHTNDF
- QUIT
- DO DSPN
- +3 QUIT
- DSPN ; DISPLAY SINGLE NOTE
- +1 SET X=$ORDER(^BCHPTP("AE",BCHTDFN,BCHTNDF,""))
- IF X=""
- QUIT
- +2 SET BCHTN=^BCHPTP(X,0)
- +3 SET BCHTDOI=$PIECE(BCHTN,U,5)
- IF BCHTDOI]""
- SET Y=BCHTDOI
- XECUTE BCHTCVD
- SET BCHTDOI=Y
- +4 SET BCHTTPT=$PIECE(BCHTN,U,7)
- SET BCHTTPT=$SELECT(BCHTTPT=1:"STP",BCHTTPT=2:"LTP",1:" ")
- +5 SET BCHHS("AUTHOR")=$PIECE(BCHTN,U,6)
- SET BCHHS("AUTHOR")=$SELECT(BCHHS("AUTHOR")]"":$$PROVINI^XBFUNC1($PIECE(BCHTN,U,6)),1:"???")
- +6 XECUTE APCHSCKP
- IF $DATA(APCHSQIT)
- QUIT
- WRITE ?1,BCHTPNM_"-"_$PIECE(BCHTN,U),?7,BCHTTPT,?11,BCHTDOI,?20,BCHHS("AUTHOR")
- +7 SET APCHSNRQ=$PIECE(BCHTN,U,4)
- SET APCHSICL=24
- SET APCHSTXT=""
- DO PRTTXT^APCHSUTL
- +8 KILL BCHTDOI
- +9 QUIT
- +10 ;
- PRTICD ;
- +1 IF BCHTNRQ=""
- SET BCHTNRQ="<no narrative provided>"
- SET BCHTICD=""
- +2 SET BCHTTXT=BCHTICD
- DO PRTTXT
- +3 QUIT
- +4 ;
- PRTTXT ; GENERALIZED TEXT PRINTER
- +1 SET BCHTDLT=1
- SET BCHTILN=80-BCHTICL-1
- +2 ;S BCHTNRQ="["_$E($P(^BCHTPROB($P(BCHTN,U),0),U,2),1,25)_"] "_BCHTNRQ
- +3 ;CMI/TUCSON/LAB - PATCH 5 changed ^BCHPROB to ^BCHTPROB 6/22/98
- SET BCHTNRQ=BCHTNRQ_" ("_$PIECE(^BCHTPROB($PIECE(BCHTN,U),0),U)_")"
- +4 IF BCHTDOO]""
- SET BCHTNRQ=BCHTNRQ_" (ONSET: "_BCHTDOO_")"
- +5 FOR BCHTQ=0:0
- IF BCHTNRQ]""&(($LENGTH(BCHTNRQ)+$LENGTH(BCHTTXT)+2)<255)
- SET BCHTTXT=$SELECT(BCHTTXT]"":BCHTTXT_"; ",1:"")_BCHTNRQ
- SET BCHTNRQ=""
- IF BCHTTXT=""
- QUIT
- DO PRTTXT2
- +6 KILL BCHTILN,BCHTDLT,BCHTF,BCHTC,BCHTTXT,BCHTDOO
- +7 QUIT
- PRTTXT2 DO GETFRAG
- WRITE ?BCHTICL
- WRITE BCHTF,!
- SET BCHTICL=BCHTICL+BCHTDLT
- SET BCHTILN=BCHTILN-BCHTDLT
- SET BCHTDLT=0
- +1 QUIT
- GETFRAG IF $LENGTH(BCHTTXT)<BCHTILN
- SET BCHTF=BCHTTXT
- SET BCHTTXT=""
- QUIT
- +1 FOR BCHTC=BCHTILN:-1:1
- IF $EXTRACT(BCHTTXT,BCHTC)=" "
- QUIT
- +2 SET BCHTF=$EXTRACT(BCHTTXT,1,BCHTC-1)
- SET BCHTTXT=$EXTRACT(BCHTTXT,BCHTC+1,255)
- +3 QUIT
- +4 ;
- GETNARR ;
- +1 IF BCHTNRQ]""
- SET BCHTNRQ=$SELECT($DATA(^AUTNPOV(BCHTNRQ)):$PIECE(^AUTNPOV(BCHTNRQ,0),U),1:"***** "_BCHTNRQ_" *****")
- +2 IF '$TEST
- SET BCHTNRQ=""
- +3 QUIT
- +4 ;
