Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BHSUTL

BHSUTL.m

Go to the documentation of this file. 
  1. BHSUTL ;IHS/CIA/MGH - Health Summary Utilities ;09-Mar-2016 09:58;du
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,7,8,9,13**;March 17, 2006;Build 6
  1.  ;===================================================================
  1.  ;Taken from APCHSUTL
  1.  ; IHS/TUCSON/LAB - UTILITIES FOR APCHS -- SUMMARY PRODUCTION COMPONENTS
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**3,8**;JUN 24, 1997
  1.  ;IHS health summary utilities to use in VA health summaries
  1.  ;Updated in patch2 for CPT codes
  1.  ;Updated in patch3 for CSV
  1.  ;Patch 8 for snomed problem list
  1.  ;Patch 9 for ICD-10
  1. GETICDDX ;ENTRY POINT
  1.  ;IHS/MSC/MGH Code set versioning changes entered
  1.  ;S Y=$P(^ICD9(BHSICD,0),U,1)
  1.  ;Patch 12 changes
  1.  I $$AICD^BHSUTL S Y=$$ICDDX^ICDEX(BHSICD,"","","I")
  1.  E  S Y=$$ICDDX^ICDCODE(BHSICD)  ;cmi/anch/maw 8/27/2007 code set version
  1.  ;Patch 13 changes
  1.  N APCHSDSC
  1.  ;I $$AICD^BHSUTL B  S APCHSDSC=$$ICDD^ICDEX($P(Y,U,1),.APCHSDSC,$G(BHSCVD))
  1.  ;E  B  S APCHSDSC=$$ICDD^ICDCODE($P(Y,U,2),.APCHSDSC)
  1.  S APCHSDSC=$P(Y,U,4)
  1.  S:GMPXICDF="L"!(GMPXICDF="Long text") BHSICD=$P(Y,U,2)_"-"_$S($D(APCHSDSC):$G(APCHSDSC),1:"<DESCRIPTION field missing>")  ;cmi/anch/maw 8/27/20
  1.  S:GMPXICDF="S"!(GMPXICDF="Short text") BHSICD=$P(Y,U,2)_"-"_$S($D(APCHSDSC):$G(APCHSDSC),1:"<DIAGNOSIS field missing>")  ;cmi/anch/maw 8/27/2007 code
  1.  S:GMPXICDF="C"!(GMPXICDF="Code only") BHSICD=$P(Y,U,2)
  1.  S:GMPXICDF="T"!(GMPXICDF="Text only") BHSICD=$P(Y,U,4)
  1.  S:GMPXICDF="N"!(GMPXICDF="None")!(GMPXICDF="") BHSICD=""
  1.  Q
  1. GETPLICD ;EP
  1.  ;IHS/MSC/MGH SNOMED changes
  1.  I $$AICD^BHSUTL S Y=$$ICDDX^ICDEX(BHSICD,"","","I")
  1.  E  S Y=$$ICDDX^ICDCODE(BHSICD)  ;cmi/anch/maw 8
  1.  S BHSICD=$P(Y,U,2)
  1.  Q
  1. GETICDOP ;ENTRY POINT
  1.  ;Patch 2 Code set versioning changed
  1.  ;S Y=$P(^ICD0(BHSICD,0),U,1)
  1.  N BHSXY
  1.  I $$AICD^BHSUTL S BHSXY=$$ICDOP^ICDEX(BHSICD,"","","I")
  1.  E  S BHSXY=$$ICDOP^ICDCODE(BHSICD)
  1.  I $P(BHSXY,U)="-1" S BHSXY=BHSICD_U_$P($G(^ICD0(BHSICD,0)),U,1)_U_U_$$VSTP^AUPNVUTL(BHSICD,$G(BHSCVD))
  1.  I $$AICD^BHSUTL S BHSDSC=$$ICDD^ICDEX($P(BHSXY,U,2),.BHSDSC,$G(BHSCVD))
  1.  E  S BHSDSC=$$ICDD^ICDCODE($P(BHSXY,U,2),.BHSDSC,$G(BHSCSVD))
  1.  S:GMPXICDF="L" BHSICD=$P(BHSXY,U,2)_"-"_$S($D(BHSDSC(1)):$G(BHSDSC(1)),1:"<DESCRIPTION field missing>")
  1.  S:GMPXICDF="S" BHSICD=$P(BHSXY,U,2)_"-"_$S($P(BHSXY,U,5)]"":$P(BHSXY,U,5),1:"<DIAGNOSIS field missing>")
  1.  S:GMPXICDF="C" BHSICD=$P(BHSXY,U,2)
  1.  Q
  1. GETCPT ;ENTRY POINT  PATCH 2
  1.  ;Patch 2Code set versioning changes
  1.  ;S Y=$P(^ICPT(BHSICD,0),U,1)
  1.  S Y=$$CPT^ICPTCOD(BHSICD)
  1.  S:GMPXICDF="L" BHSICD=$P(Y,U,2)_"-"_$S($P(Y,U,3)]"":$P(Y,U,3),1:"<DESCRIPTION field missing>")
  1.  S:GMPXICDF="S" BHSICD=$P(Y,U,2)_"-"_$S($P(Y,U,3)]"":$P(Y,U,3),1:"<DESCRIPTION field missing>")
  1.  S:GMPXICDF="C" BHSICD=$P(Y,U,2)
  1.  Q
  1. PRTICD ;ENTRY POINT
  1.  ;I GMPXNARR="N" S:BHSNRQ="" BHSNRQ="<no narrative provided>" S BHSICD=""
  1.  S BHSTXT=BHSICD
  1.  ;I GMPXNARR="Y" S BHSTXT=BHSTXT_" "_BHSNRQ
  1.  S:'$D(BHSNTE) BHSNTE=""
  1.  I BHSNTE]"" S BHSNTE=" "_BHSNTE
  1.  D PRTTXT
  1.  Q
  1.  ;
  1. PRTICDE ;ENTRY POINT
  1.  I BHSICF="N" S BHSICD=""
  1.  S:'$D(BHSNTE) BHSNTE=""
  1.  I BHSNTE]"" S BHSNTE=" "_BHSNTE
  1.  D PRTTXT
  1.  Q         ;
  1. PRTTXT ;PEP - PUBLISHED ENTRY POINT
  1.  ; GENERALIZED TEXT PRINTER
  1.  N BHSQ
  1.  S:'$D(BHSNTE) BHSNTE=""
  1.  S BHSDLT=1,BHSILN=IOM-BHSICL-1
  1.  F BHSQ=0:0 D PRTTXT1 Q:BHSTXT=""  D PRTTXT2
  1.  K BHSNTE
  1.  K BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
  1.  Q
  1. PRTTXT1 ;
  1.  I GMPXNARR'="N" D
  1.  .S:BHSNRQ]""&(($L(BHSNRQ)+$L(BHSTXT)+2)<255) BHSTXT=$S(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ,BHSNRQ=""
  1.  .S:BHSNTE]""&(BHSNRQ="")&(($L(BHSNTE)+$L(BHSTXT)+2)<255) BHSTXT=BHSTXT_BHSNTE,BHSNTE=""
  1.  I GMPXNARR="N" D
  1.  .S:($L(BHSTXT)+2)<255 BHSTXT=$S(BHSTXT]"":BHSTXT_"; ",1:""),BHSNRQ=""
  1.  .S:BHSNTE]""&(($L(BHSTXT)+2)<255) BHSTXT=BHSTXT_BHSNTE,BHSNTE=""
  1.  Q
  1. PRTTXT2 D GETFRAG D CKP^GMTSUP Q:$D(GMTSQIT)  W ?BHSICL W BHSF,!
  1.  S BHSICL=BHSICL+BHSDLT,BHSILN=BHSILN-BHSDLT,BHSDLT=0
  1.  Q
  1. GETFRAG I $L(BHSTXT)<BHSILN S BHSF=BHSTXT,BHSTXT="" Q
  1.  F BHSC=BHSILN:-1:0 Q:$E(BHSTXT,BHSC)=" "
  1.  S:BHSC=0 BHSC=BHSILN
  1.  S BHSF=$E(BHSTXT,1,BHSC-1),BHSTXT=$E(BHSTXT,BHSC+1,255)
  1.  Q
  1.  ;
  1. GETNARR ;ENTRY POINT
  1.  ;I BHSNRQ]"",GMPXNARR="Y" S BHSNRQ=$S($D(^AUTNPOV(BHSNRQ)):$P(^AUTNPOV(BHSNRQ,0),U,1),1:"***** "_BHSNRQ_" *****")
  1.  N SNONAR
  1.  S SNONAR=""
  1.  I BHSNRQ]"",GMPXNARR="Y" D
  1.  .S SNONAR=$$SNOMED^AUPNVUTL(BHSNRQ)
  1.  .S BHSNRQ=$S(SNONAR'="":SNONAR,1:"***** "_BHSNRQ_" *****")
  1.  E  S BHSNRQ=""
  1.  Q
  1.  ;
  1. GETSITEV ;ENTRY POINT
  1.  S BHSP=^AUPNVSIT(BHSVDF,0),BHSVSC=$P(BHSP,U,7),BHSITE=$P(BHSP,U,6)
  1. GETSITE ;ENTRY POINT
  1.  S:BHSITE="" BHSITE="null"
  1.  S BHSP=$G(^AUTTLOC(BHSITE,0))
  1.  S:'$D(BHSVDF) BHSVDF=-1
  1.  S BHSNFL=$P(BHSP,U,1) S:BHSNFL="" BHSNFL="null" S BHSNFL=$S($D(^DIC(4,BHSNFL,0)):$P(^(0),U,1),$P($G(^AUPNVSIT(BHSVDF,21)),U)]"":$P(^(21),U),1:"<"_BHSITE_">") ;IHS/CMI/LAB - fixed this line
  1.  S BHSNSH=$P(BHSP,U,2) S:$P($G(^AUPNVSIT(BHSVDF,21)),U)]"" BHSNSH=$E($P(^(21),U),1,12) I BHSNSH="" S BHSNSH="<"_BHSITE_">" ;IHS/CMI/LAB - fixed this line to replace the one above
  1.  K:BHSVDF=-1 BHSVDF
  1.  S BHSNAB=$J($P(BHSP,U,7),4) I BHSNAB="" S BHSNAB="<"_BHSITE_">"
  1.  Q
  1.  ;
  1.  ; THE FOLLOWING CODE SEGMENTS ARE CALLED FROM 'ROUTINE"-TYPE
  1.  ;  MENU OPTIONS TO DISPLAY ITEMS IN A FILE
  1.  ;
  1. LM ;ENTRY POINT - FOR BHSLST MEASUREMENT PANEL TYPES
  1.  S BHSLST="^APCHSMPN(" G DSPLST
  1.  ;
  1. LI ;ENTRY POINT - FOR BHSLST HLTH SUM FLOWSHEET ITEMS
  1.  S BHSLST="^APCHSFLI(" G DSPLST
  1.  ;
  1. LF ;ENTRY POINT - FOR BHSLST HLTH SUM FLOWSHEETS
  1.  S BHSLST="^APCHSFLC(" G DSPLST
  1.  ;
  1. DSPLST ; COMMON CODE FOR BUILD HLTH SUM & HLTH SUM MNX LISTS
  1.  K DIR
  1.  I '$D(@(BHSLST_"""B"")")) W !,"NO ",$P(@(BHSLST_"0)"),U),"S DEFINED.",! Q
  1.  W @IOF,!!,"Existing ",$P(@(BHSLST_"0)"),U),"S:",! S BHSCNT=""
  1. CONT F  S BHSCNT=$O(@(BHSLST_"""B"",BHSCNT)")) Q:BHSCNT=""  W !,?5,BHSCNT I (IOSL-3)<$Y S DIR(0)="E" D ^DIR W @IOF G:1'[Y QUIT
  1.  K DIR S DIR(0)="E" D ^DIR W !
  1.  Q
  1.  ;
  1. GENFG ;generate filegrams for export
  1. MEASPAN ;
  1.  N DIFG,DIFGT,DILC,DIFGER
  1.  W !,"REMEMBER TO KILL APCHTMP BEFORE DOING THIS",!
  1.  S APCHT="MEASPAN",APCHC=0 F APCHX="ADULT STD","ADULT STD METRIC","PEDIATRIC STD","PEDIATRIC STD METRIC" S DIFGT=$O(^DIPT("B","APCH MP TYPE",0)) D
  1.  .I 'DIFGT W !,"measurement panel fg missing" Q
  1.  .S DIFG("FE")=$O(^BHS(90470,"B",APCHX,0))
  1.  .I 'DIFG("FE") W !,"panel ",APCHX," missing.",! Q
  1.  .S APCHC=APCHC+1
  1.  .D GEN1
  1.  .Q
  1. FLOW ;
  1.  G TYPE
  1.  S APCHT="FLOW",APCHC=0 F APCHX="DIABETIC FLOWSHEET" S DIFGT=$O(^DIPT("B","APCH FS TYPE",0)) D
  1.  .I 'DIFGT W !,"flowsheet fg missing" Q
  1.  .S DIFG("FE")=$O(^APCHSFLC("B",APCHX,0))
  1.  .I 'DIFG("FE") W !,"flowsheet ",APCHX," missing.",! Q
  1.  .S APCHC=APCHC+1
  1.  .D GEN1
  1.  .Q
  1. TYPE ;
  1.  S APCHT="TYPE",APCHC=0 F APCHX="ADULT REGULAR","CHR","DENTAL","DIABETES STANDARD","IMMUNIZATION","MENTAL HEALTH/SOCIAL SERVICES","PEDIATRIC","PATIENT MERGE (COMPLETE)","PROBLEM LIST" S DIFGT=$O(^DIPT("B","APCH HS TYPE",0)) D
  1.  .I 'DIFGT W !,"health summary type fg missing" Q
  1.  .S DIFG("FE")=$O(^GMT(142,"B",APCHX,0))
  1.  .I 'DIFG("FE") W !,"type ",APCHX," missing.",! Q
  1.  .S APCHC=APCHC+1
  1.  .D GEN1
  1.  .Q
  1.  K APCHC,APCHT W !,"all done"
  1.  Q
  1. GEN1 ;
  1.  S DIFG("FUNC")="A"
  1.  S DIFG("FGR")="^APCHTMP("""_APCHT_""",APCHC,"
  1.  S DILC=0
  1.  D EN^DIFGG
  1.  I $D(DIFGER) W !,"error on ",APCHT," item ",APCHX,!
  1.  Q
  1. QUIT K DIR,X,Y,BHSLST,BHSCNT
  1.  Q
  1. AICD() ;EP
  1.  Q $S($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)