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 ;
