BHSPLST1 ;IHS/MSC/MGH - Health Summary for Problem list;28-Apr-2016 14:48;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
;
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" G COMMON
PPROB S BHSTAT="I",BHSPER=1
; <SETUP>
COMMON ;
K BHSDFT S BHSNDF=0
S BHSPER=$G(BHSPER)
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
; <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
PROBX K BHSDFT,BHSNDF,BHSFPP,BHSFAC,BHSPLN,BHSPBN,BHSDTM,BHSDTN,BHSPRB,BHSTAT,BHSNFP,BHSNRQ,BHSPNM,BHSDFN,BHSFCN,BHSICD,BHSDOO
K BHSICL,BHSILN,BHSN,BHSNAR,BHSNTE,BHSAX,BHSCL,BHSTXT,BHSQ,BHSICF,BHSP
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,BHSVD,BHSX,BHSPAT,BHSPER,I,X
Q
PROBSCH ;
S BHSPRB="" F BHSQ=0:0 S BHSPRB=$O(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB)) Q:BHSPRB="" D
.S BHSDFN=$O(^(BHSPRB,""))
.I BHSDFN'="" S BHSNAR=$$GET1^DIQ(9000011,BHSDFN,.05)
.I BHSTAT[$P(^AUPNPROB(BHSDFN,0),U,12) D
..Q:BHSPER=1&($P(^AUPNPROB(BHSDFN,0),U,4)'="P")
..S BHSNDF=BHSNDF+1,BHSDFT(BHSNAR)=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
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
N NTEDTE
Q:$P(BHSN,U,4)="E"
Q:$P(BHSN,U,4)="I"
S BHSNAR=$P(BHSN,U,3) S X=$P(BHSN,U,5)
I X>0 D REGDT4^GMTSU S NTEDTE=X
F BHSQ=0:0 Q:$E(BHSFCN)'=" " S BHSFCN=$E(BHSFCN,2,99)
D CKP^GMTSUP Q:$D(GMTSQIT) W "Note: "_BHSFCN_" "_$P(BHSN,U)_" on "_NTEDTE
S BHSTXT=BHSNAR,BHSICL=34 D PRTTXT^BHSUTL
Q
BHSPLST1 ;IHS/MSC/MGH - Health Summary for Problem list;28-Apr-2016 14:48;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 ;
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"
GOTO COMMON
PPROB SET BHSTAT="I"
SET BHSPER=1
+1 ; <SETUP>
COMMON ;
+1 KILL BHSDFT
SET BHSNDF=0
+2 SET BHSPER=$GET(BHSPER)
+3 SET BHSPAT=DFN
+4 SET BHSFAC=""
FOR BHSQ=0:0
SET BHSFAC=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC))
IF 'BHSFAC
QUIT
DO PROBSCH
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO PROBX
IF 'GMTSNPG
WRITE !
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
GOTO PROBX
+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
PROBX KILL BHSDFT,BHSNDF,BHSFPP,BHSFAC,BHSPLN,BHSPBN,BHSDTM,BHSDTN,BHSPRB,BHSTAT,BHSNFP,BHSNRQ,BHSPNM,BHSDFN,BHSFCN,BHSICD,BHSDOO
+1 KILL BHSICL,BHSILN,BHSN,BHSNAR,BHSNTE,BHSAX,BHSCL,BHSTXT,BHSQ,BHSICF,BHSP
+2 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,Y,BHSVD,BHSX,BHSPAT,BHSPER,I,X
+3 QUIT
PROBSCH ;
+1 SET BHSPRB=""
FOR BHSQ=0:0
SET BHSPRB=$ORDER(^AUPNPROB("AA",BHSPAT,BHSFAC,BHSPRB))
IF BHSPRB=""
QUIT
Begin DoDot:1
+2 SET BHSDFN=$ORDER(^(BHSPRB,""))
+3 IF BHSDFN'=""
SET BHSNAR=$$GET1^DIQ(9000011,BHSDFN,.05)
+4 IF BHSTAT[$PIECE(^AUPNPROB(BHSDFN,0),U,12)
Begin DoDot:2
+5 IF BHSPER=1&($PIECE(^AUPNPROB(BHSDFN,0),U,4)'="P")
QUIT
+6 SET BHSNDF=BHSNDF+1
SET BHSDFT(BHSNAR)=BHSDFN
End DoDot:2
End DoDot:1
+7 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 DO NOTEDSP
+42 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 NEW NTEDTE
+2 IF $PIECE(BHSN,U,4)="E"
QUIT
+3 IF $PIECE(BHSN,U,4)="I"
QUIT
+4 SET BHSNAR=$PIECE(BHSN,U,3)
SET X=$PIECE(BHSN,U,5)
+5 IF X>0
DO REGDT4^GMTSU
SET NTEDTE=X
+6 FOR BHSQ=0:0
IF $EXTRACT(BHSFCN)'=" "
QUIT
SET BHSFCN=$EXTRACT(BHSFCN,2,99)
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE "Note: "_BHSFCN_" "_$PIECE(BHSN,U)_" on "_NTEDTE
+8 SET BHSTXT=BHSNAR
SET BHSICL=34
DO PRTTXT^BHSUTL
+9 QUIT
