- 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