BHSPLST ;IHS/MSC/MGH - Health Summary for Problem list;04-Jan-2016 10:26;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**13**;Mar 17,2006;Build 6
; IHS/CMI/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;31-Mar-2014 16:53;DU
;
PROBST ;EP - problems by status
NEW BHPBST,BHST
S BHSTAT="AEOS"
S BHSPAT=DFN
S BHSNDF=0
S BHSFAC="" F BHSQ=0:0 S BHSFAC=$O(^AUPNPROB("AA",BHSPAT,BHSFAC)) Q:'BHSFAC D
.S BHSPRB="" F BHSQ=0:0 S BHSPRB=$O(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB)) Q:BHSPRB="" D
..S BHSDFN=$O(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB,""))
..S BHST=$P(^AUPNPROB(BHSDFN,0),U,12)
..Q:BHST=""
..Q:"AEOS"'[BHST
..S BHSNDF=BHSNDF+1,BHSDFT(BHST,BHSFAC_BHSPRB)=BHSDFN
D CKP^GMTSUP G:$D(GMTSQIT) PROBX I 'GMTSNPG W ! D CKP^GMTSUP G:$D(GMTSQIT) PROBX
I BHSNDF=0 G COMMON1
W ?12,"ENT. MODIFIED",!
F BHST="A","S","E","O" D
.S BHSFPP="" F BHSQ=0:0 S BHSFPP=$O(BHSDFT(BHST,BHSFPP)) Q:BHSFPP="" S BHSDFN=BHSDFT(BHST,BHSFPP) D PROBDSP
G COMMON1
PROB ; ******************** PROBLEM / NOTES * 9000011 *********
APROB S BHSTAT="ASEO" G COMMON
CPROB S BHSTAT="A" G COMMON
SPROB S BHSTAT="S" G COMMON
OPROB S BHSTAT="O" G COMMON
EPROB S BHSTAT="E" G COMMON
IPROB S BHSTAT="I"
; <SETUP>
COMMON ;
K BHSDFT S BHSNDF=0
S BHSPAT=DFN
S BHSFAC="" F BHSQ=0:0 S BHSFAC=$O(^AUPNPROB("AA",BHSPAT,BHSFAC)) Q:'BHSFAC D PROBSCH
D CKP^GMTSUP G:$D(GMTSQIT) PROBX I 'GMTSNPG W ! D CKP^GMTSUP G:$D(GMTSQIT) PROBX
I BHSNDF=0 G COMMON1
; <DISPLAY>
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?13,"ENT. MODIFIED",!
S BHSFPP="" F BHSQ=0:0 S BHSFPP=$O(BHSDFT(BHSFPP)) Q:BHSFPP=""!($D(GMTSQIT)) S BHSDFN=BHSDFT(BHSFPP) D PROBDSP
COMMON1 ;additional stuff for CHHIT bjpc 2.0 patch 5
;get date last reviewed and display
S BHSX=$$LASTPLR^APCLAPI6(BHSPAT,,DT,"A")
Q:$D(GMTSQIT)
W !,"Problem List Reviewed On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?54,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
S BHSX=$$LASTPLU^APCLAPI6(BHSPAT,,DT,"A")
Q:$D(GMTSQIT)
W "Problem List Updated On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",?54,$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
I BHSTAT]"" D
.S BHSX=$$LASTNAP^APCLAPI6(BHSPAT,,DT,"A")
.Q:$D(GMTSQIT)
.;I '$$ANYACTP^APCDAPRB(BHSPAT) W !,"No Active Problems: ",?24,$$FMTE^XLFDT($P(BHSX,U,1)) I $P(BHSX,U,3) W ?39,"Documented By: ",?54,$E($P($G(^VA(200,$P(BHSX,U,3),0)),U),1,25),!
.W "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($P(BHSX,U,1)) W ?51,"By: ",$E($S($P(BHSX,U,3):$P($G(^VA(200,$P(BHSX,U,3),0)),U),1:""),1,25),!
PROBX K BHSDFT,BHSNDF,BHSFPP,BHSFAC,BHSPLN,BHSPBN,BHSDFN,BHSDTM,BHSDTN,BHSPRB,BHSTAT,BHSNFP,BHSNRQ,BHSPNM,BHSDFN,BHSFCN,BHSICD,BHSDOO
K BHSICL,BHSILN,BHSN,BHSNAR,BHSNTE,BHSAX,BHSCL,BHSTXT,BHSQ,BHSICF
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,BHSVD,BHSX,BHSP,I,BHSPAT
Q
PROBSCH ;
S BHSPRB="" F BHSQ=0:0 S BHSPRB=$O(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB)) Q:BHSPRB="" S BHSDFN=$O(^(BHSPRB,"")) S:BHSTAT[$P(^AUPNPROB(BHSDFN,0),U,12) BHSNDF=BHSNDF+1,BHSDFT(BHSFAC_BHSPRB)=BHSDFN
Q
PROBDSP ;
; <SETUP PROBLEM>
S BHSNTE="",BHSDOO=""
S BHSN=^AUPNPROB(BHSDFN,0)
S BHSVD=$P(^AUPNPROB(BHSDFN,0),U,3)
S BHSICD=$P(BHSN,U,1) D GETPLICD^BHSUTL
S BHSNRQ=""
S BHSNRQ=$$GET1^DIQ(9000011,BHSDFN_",",.05)
S X=$$GET1^DIQ(9000011,BHSDFN_",",80001) I X]"" S BHSNRQ=BHSNRQ_" ("_X_")"
S BHSITE=$P(BHSN,U,6) D GETSITE^BHSUTL
S BHSPNM=$P(BHSN,U,7) ;***** EDE *****
S BHSPNM=BHSNAB_BHSPNM ;***** EDE *****
S X=$P(BHSN,U,3) D REGDT4^GMTSU S BHSDTM=X
S X=$P(BHSN,U,8) D REGDT4^GMTSU S BHSDTN=X
S BHSCL=$$VAL^XBDIQ1(9000011,BHSDFN,.15)
I BHSCL]"" S BHSNTE=" "_$$CAT^AUPNVPLC($P(BHSN,U,1))_": "_BHSCL
S X=$P(BHSN,U,13) I X]"" D REGDT4^GMTSU S BHSDOO=X
S:BHSDOO]"" BHSNTE=BHSNTE_" (onset "_BHSDOO_")"
S BHSNTE=BHSNTE_"(Status: "_$$VAL^XBDIQ1(9000011,BHSDFN,.12)_")"
S BHSPLN=BHSPNM_$E(" ",1,10-$L(BHSPNM))_BHSDTN_" "_BHSDTM
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG ?12,"ENT. MODIFIED",!
W BHSPLN S BHSICL=33,BHSILN=50 D PRTICD^BHSUTL
I $P(BHSN,U,16)!($P(BHSN,U,17))!($P(BHSN,U,18)) D ECODEDSP
;SEVERITY
I $O(^AUPNPROB(BHSDFN,13,0)) D
.W ?33,"Severity: "
.S BHSAX=0 F S BHSAX=$O(^AUPNPROB(BHSDFN,13,BHSAX)) Q:BHSAX'=+BHSAX D
..S I=BHSAX_","_BHSDFN
..W ?42,$$GET1^DIQ(9000011.13,I,.01)_" - "_$$GET1^DIQ(9000011.13,I,.019),!
;FINDING SITE
I $O(^AUPNPROB(BHSDFN,17,0)) D
.W ?33,"Finding Site: "
.S BHSAX=0 F S BHSAX=$O(^AUPNPROB(BHSDFN,17,BHSAX)) Q:BHSAX'=+BHSAX D
..S I=BHSAX_","_BHSDFN
..W ?42,$$GET1^DIQ(9000011.17,I,.01),!
;clinical course
I $O(^AUPNPROB(BHSDFN,18,0)) D
.W ?33,"Clinical Course: "
.S BHSAX=0 F S BHSAX=$O(^AUPNPROB(BHSDFN,18,BHSAX)) Q:BHSAX'=+BHSAX D
..S I=BHSAX_","_BHSDFN
..W ?42,$$GET1^DIQ(9000011.18,I,.01)_" - "_$$GET1^DIQ(9000011.18,I,.019),!
;D NOTEDSP
D RECON^BHSPL(BHSDFN)
Q
ECODEDSP ;
D CKP^GMTSUP Q:$D(GMTSQIT)
W ?33,"CAUSE: ",!
F BHSP=16,17,18 D Q:$D(GMTSQIT)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W:GMTSNPG ?13,"ENT. MODIFIED",!
.S BHSTXT=""
.S BHSICD=$P(BHSN,U,BHSP)
.Q:BHSICD=""
.S BHSNRQ=$S(BHSICF="N":$P($$ICDDX^ICDEX($P(BHSN,U,BHSP),"","","I"),U,4),BHSICF="L":$P($$ICDDX^AUPNVUTL($P(BHSN,U,BHSP)),U,4),1:"")
.;D GETICDDX^BHSUTL
. D GETPLICD^BHSUTL
.I BHSICF="C"!(BHSICF="") S BHSNRQ=BHSICD_"-"_$P($$ICDDX^ICDEX($P(BHSN,U,BHSP),"","","I"),U,4)
.I BHSICF="L" S BHSNRQ=BHSICD
.S BHSICL=33,BHSILN=50
.D PRTICDE^BHSUTL
.Q
Q
NOTEDSP ; DISPLAY NOTES UNDER APCHSPRBLEM
S BHSNFP=0 F BHSQ=0:0 S BHSNFP=$O(^AUPNPROB(BHSDFN,11,BHSNFP)) Q:'BHSNFP D DSPFACN
Q
DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
Q:$D(^AUPNPROB(BHSDFN,11,BHSNFP,11,0))'=1 Q:$O(^(0))=""
S BHSITE=^AUPNPROB(BHSDFN,11,BHSNFP,0) D GETSITE^BHSUTL S BHSFCN=BHSNAB
S BHSNDF=0 F BHSQ=0:0 S BHSNDF=$O(^AUPNPROB(BHSDFN,11,BHSNFP,11,BHSNDF)) Q:'BHSNDF S BHSN=^(BHSNDF,0) D DSPN
Q
DSPN ; DISPLAY SINGLE NOTE
Q:$P(BHSN,U,4)="E"
Q:$P(BHSN,U,4)="I"
S BHSNAR=$P(BHSN,U,3) S Y=$P(BHSN,U,5) ;S:Y="" Y=" "
N X
I X>0 D REGDT4^GMTSU S X=X_" - "
S BHSNAR=X_BHSNAR
F BHSQ=0:0 Q:$E(BHSFCN)'=" " S BHSFCN=$E(BHSFCN,2,99)
D CKP^GMTSUP Q:$D(GMTSQIT) W BHSFCN_" "_$P(BHSN,U)
S BHSTXT=BHSNAR,BHSICL=34 D PRTTXT^BHSUTL
Q
BHSPLST ;IHS/MSC/MGH - Health Summary for Problem list;04-Jan-2016 10:26;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**13**;Mar 17,2006;Build 6
+2 ; IHS/CMI/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;31-Mar-2014 16:53;DU
+3 ;
PROBST ;EP - problems by status
+1 NEW BHPBST,BHST
+2 SET BHSTAT="AEOS"
+3 SET BHSPAT=DFN
+4 SET BHSNDF=0
+5 SET BHSFAC=""
FOR BHSQ=0:0
SET BHSFAC=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC))
IF 'BHSFAC
QUIT
Begin DoDot:1
+6 SET BHSPRB=""
FOR BHSQ=0:0
SET BHSPRB=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB))
IF BHSPRB=""
QUIT
Begin DoDot:2
+7 SET BHSDFN=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB,""))
+8 SET BHST=$PIECE(^AUPNPROB(BHSDFN,0),U,12)
+9 IF BHST=""
QUIT
+10 IF "AEOS"'[BHST
QUIT
+11 SET BHSNDF=BHSNDF+1
SET BHSDFT(BHST,BHSFAC_BHSPRB)=BHSDFN
End DoDot:2
End DoDot:1
+12 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO PROBX
IF 'GMTSNPG
WRITE !
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO PROBX
+13 IF BHSNDF=0
GOTO COMMON1
+14 WRITE ?12,"ENT. MODIFIED",!
+15 FOR BHST="A","S","E","O"
Begin DoDot:1
+16 SET BHSFPP=""
FOR BHSQ=0:0
SET BHSFPP=$ORDER(BHSDFT(BHST,BHSFPP))
IF BHSFPP=""
QUIT
SET BHSDFN=BHSDFT(BHST,BHSFPP)
DO PROBDSP
End DoDot:1
+17 GOTO COMMON1
PROB ; ******************** PROBLEM / NOTES * 9000011 *********
APROB SET BHSTAT="ASEO"
GOTO COMMON
CPROB SET BHSTAT="A"
GOTO COMMON
SPROB SET BHSTAT="S"
GOTO COMMON
OPROB SET BHSTAT="O"
GOTO COMMON
EPROB SET BHSTAT="E"
GOTO COMMON
IPROB SET BHSTAT="I"
+1 ; <SETUP>
COMMON ;
+1 KILL BHSDFT
SET BHSNDF=0
+2 SET BHSPAT=DFN
+3 SET BHSFAC=""
FOR BHSQ=0:0
SET BHSFAC=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC))
IF 'BHSFAC
QUIT
DO PROBSCH
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO PROBX
IF 'GMTSNPG
WRITE !
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO PROBX
+5 IF BHSNDF=0
GOTO COMMON1
+6 ; <DISPLAY>
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 WRITE ?13,"ENT. MODIFIED",!
+9 SET BHSFPP=""
FOR BHSQ=0:0
SET BHSFPP=$ORDER(BHSDFT(BHSFPP))
IF BHSFPP=""!($DATA(GMTSQIT))
QUIT
SET BHSDFN=BHSDFT(BHSFPP)
DO PROBDSP
COMMON1 ;additional stuff for CHHIT bjpc 2.0 patch 5
+1 ;get date last reviewed and display
+2 SET BHSX=$$LASTPLR^APCLAPI6(BHSPAT,,DT,"A")
+3 IF $DATA(GMTSQIT)
QUIT
+4 WRITE !,"Problem List Reviewed On: ",?36,$$FMTE^XLFDT($PIECE(BHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(BHSX,U,3):$PIECE($GET(^VA(200,$PIECE(BHSX,U,3),0)),U),1:""),1,25),!
+5 SET BHSX=$$LASTPLU^APCLAPI6(BHSPAT,,DT,"A")
+6 IF $DATA(GMTSQIT)
QUIT
+7 WRITE "Problem List Updated On: ",?36,$$FMTE^XLFDT($PIECE(BHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(BHSX,U,3):$PIECE($GET(^VA(200,$PIECE(BHSX,U,3),0)),U),1:""),1,25),!
+8 IF BHSTAT]""
Begin DoDot:1
+9 SET BHSX=$$LASTNAP^APCLAPI6(BHSPAT,,DT,"A")
+10 IF $DATA(GMTSQIT)
QUIT
+11 ;I '$$ANYACTP^APCDAPRB(BHSPAT) W !,"No Active Problems: ",?24,$$FMTE^XLFDT($P(BHSX,U,1)) I $P(BHSX,U,3) W ?39,"Documented By: ",?54,$E($P($G(^VA(200,$P(BHSX,U,3),0)),U),1,25),!
+12 WRITE "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($PIECE(BHSX,U,1))
WRITE ?51,"By: ",$EXTRACT($SELECT($PIECE(BHSX,U,3):$PIECE($GET(^VA(200,$PIECE(BHSX,U,3),0)),U),1:""),1,25),!
End DoDot:1
PROBX KILL BHSDFT,BHSNDF,BHSFPP,BHSFAC,BHSPLN,BHSPBN,BHSDFN,BHSDTM,BHSDTN,BHSPRB,BHSTAT,BHSNFP,BHSNRQ,BHSPNM,BHSDFN,BHSFCN,BHSICD,BHSDOO
+1 KILL BHSICL,BHSILN,BHSN,BHSNAR,BHSNTE,BHSAX,BHSCL,BHSTXT,BHSQ,BHSICF
+2 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,BHSVD,BHSX,BHSP,I,BHSPAT
+3 QUIT
PROBSCH ;
+1 SET BHSPRB=""
FOR BHSQ=0:0
SET BHSPRB=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB))
IF BHSPRB=""
QUIT
SET BHSDFN=$ORDER(^(BHSPRB,""))
IF BHSTAT[$PIECE(^AUPNPROB(BHSDFN,0),U,12)
SET BHSNDF=BHSNDF+1
SET BHSDFT(BHSFAC_BHSPRB)=BHSDFN
+2 QUIT
PROBDSP ;
+1 ; <SETUP PROBLEM>
+2 SET BHSNTE=""
SET BHSDOO=""
+3 SET BHSN=^AUPNPROB(BHSDFN,0)
+4 SET BHSVD=$PIECE(^AUPNPROB(BHSDFN,0),U,3)
+5 SET BHSICD=$PIECE(BHSN,U,1)
DO GETPLICD^BHSUTL
+6 SET BHSNRQ=""
+7 SET BHSNRQ=$$GET1^DIQ(9000011,BHSDFN_",",.05)
+8 SET X=$$GET1^DIQ(9000011,BHSDFN_",",80001)
IF X]""
SET BHSNRQ=BHSNRQ_" ("_X_")"
+9 SET BHSITE=$PIECE(BHSN,U,6)
DO GETSITE^BHSUTL
+10 ;***** EDE *****
SET BHSPNM=$PIECE(BHSN,U,7)
+11 ;***** EDE *****
SET BHSPNM=BHSNAB_BHSPNM
+12 SET X=$PIECE(BHSN,U,3)
DO REGDT4^GMTSU
SET BHSDTM=X
+13 SET X=$PIECE(BHSN,U,8)
DO REGDT4^GMTSU
SET BHSDTN=X
+14 SET BHSCL=$$VAL^XBDIQ1(9000011,BHSDFN,.15)
+15 IF BHSCL]""
SET BHSNTE=" "_$$CAT^AUPNVPLC($PIECE(BHSN,U,1))_": "_BHSCL
+16 SET X=$PIECE(BHSN,U,13)
IF X]""
DO REGDT4^GMTSU
SET BHSDOO=X
+17 IF BHSDOO]""
SET BHSNTE=BHSNTE_" (onset "_BHSDOO_")"
+18 SET BHSNTE=BHSNTE_"(Status: "_$$VAL^XBDIQ1(9000011,BHSDFN,.12)_")"
+19 SET BHSPLN=BHSPNM_$EXTRACT(" ",1,10-$LENGTH(BHSPNM))_BHSDTN_" "_BHSDTM
+20 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE ?12,"ENT. MODIFIED",!
+21 WRITE BHSPLN
SET BHSICL=33
SET BHSILN=50
DO PRTICD^BHSUTL
+22 IF $PIECE(BHSN,U,16)!($PIECE(BHSN,U,17))!($PIECE(BHSN,U,18))
DO ECODEDSP
+23 ;SEVERITY
+24 IF $ORDER(^AUPNPROB(BHSDFN,13,0))
Begin DoDot:1
+25 WRITE ?33,"Severity: "
+26 SET BHSAX=0
FOR
SET BHSAX=$ORDER(^AUPNPROB(BHSDFN,13,BHSAX))
IF BHSAX'=+BHSAX
QUIT
Begin DoDot:2
+27 SET I=BHSAX_","_BHSDFN
+28 WRITE ?42,$$GET1^DIQ(9000011.13,I,.01)_" - "_$$GET1^DIQ(9000011.13,I,.019),!
End DoDot:2
End DoDot:1
+29 ;FINDING SITE
+30 IF $ORDER(^AUPNPROB(BHSDFN,17,0))
Begin DoDot:1
+31 WRITE ?33,"Finding Site: "
+32 SET BHSAX=0
FOR
SET BHSAX=$ORDER(^AUPNPROB(BHSDFN,17,BHSAX))
IF BHSAX'=+BHSAX
QUIT
Begin DoDot:2
+33 SET I=BHSAX_","_BHSDFN
+34 WRITE ?42,$$GET1^DIQ(9000011.17,I,.01),!
End DoDot:2
End DoDot:1
+35 ;clinical course
+36 IF $ORDER(^AUPNPROB(BHSDFN,18,0))
Begin DoDot:1
+37 WRITE ?33,"Clinical Course: "
+38 SET BHSAX=0
FOR
SET BHSAX=$ORDER(^AUPNPROB(BHSDFN,18,BHSAX))
IF BHSAX'=+BHSAX
QUIT
Begin DoDot:2
+39 SET I=BHSAX_","_BHSDFN
+40 WRITE ?42,$$GET1^DIQ(9000011.18,I,.01)_" - "_$$GET1^DIQ(9000011.18,I,.019),!
End DoDot:2
End DoDot:1
+41 ;D NOTEDSP
+42 DO RECON^BHSPL(BHSDFN)
+43 QUIT
ECODEDSP ;
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+2 WRITE ?33,"CAUSE: ",!
+3 FOR BHSP=16,17,18
Begin DoDot:1
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 IF GMTSNPG
WRITE ?13,"ENT. MODIFIED",!
+6 SET BHSTXT=""
+7 SET BHSICD=$PIECE(BHSN,U,BHSP)
+8 IF BHSICD=""
QUIT
+9 SET BHSNRQ=$SELECT(BHSICF="N":$PIECE($$ICDDX^ICDEX($PIECE(BHSN,U,BHSP),"","","I"),U,4),BHSICF="L":$PIECE($$ICDDX^AUPNVUTL($PIECE(BHSN,U,BHSP)),U,4),1:"")
+10 ;D GETICDDX^BHSUTL
+11 DO GETPLICD^BHSUTL
+12 IF BHSICF="C"!(BHSICF="")
SET BHSNRQ=BHSICD_"-"_$PIECE($$ICDDX^ICDEX($PIECE(BHSN,U,BHSP),"","","I"),U,4)
+13 IF BHSICF="L"
SET BHSNRQ=BHSICD
+14 SET BHSICL=33
SET BHSILN=50
+15 DO PRTICDE^BHSUTL
+16 QUIT
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+17 QUIT
NOTEDSP ; DISPLAY NOTES UNDER APCHSPRBLEM
+1 SET BHSNFP=0
FOR BHSQ=0:0
SET BHSNFP=$ORDER(^AUPNPROB(BHSDFN,11,BHSNFP))
IF 'BHSNFP
QUIT
DO DSPFACN
+2 QUIT
DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
+1 IF $DATA(^AUPNPROB(BHSDFN,11,BHSNFP,11,0))'=1
QUIT
IF $ORDER(^(0))=""
QUIT
+2 SET BHSITE=^AUPNPROB(BHSDFN,11,BHSNFP,0)
DO GETSITE^BHSUTL
SET BHSFCN=BHSNAB
+3 SET BHSNDF=0
FOR BHSQ=0:0
SET BHSNDF=$ORDER(^AUPNPROB(BHSDFN,11,BHSNFP,11,BHSNDF))
IF 'BHSNDF
QUIT
SET BHSN=^(BHSNDF,0)
DO DSPN
+4 QUIT
DSPN ; DISPLAY SINGLE NOTE
+1 IF $PIECE(BHSN,U,4)="E"
QUIT
+2 IF $PIECE(BHSN,U,4)="I"
QUIT
+3 ;S:Y="" Y=" "
SET BHSNAR=$PIECE(BHSN,U,3)
SET Y=$PIECE(BHSN,U,5)
+4 NEW X
+5 IF X>0
DO REGDT4^GMTSU
SET X=X_" - "
+6 SET BHSNAR=X_BHSNAR
+7 FOR BHSQ=0:0
IF $EXTRACT(BHSFCN)'=" "
QUIT
SET BHSFCN=$EXTRACT(BHSFCN,2,99)
+8 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE BHSFCN_" "_$PIECE(BHSN,U)
+9 SET BHSTXT=BHSNAR
SET BHSICL=34
DO PRTTXT^BHSUTL
+10 QUIT
