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

BHSNRS.m

Go to the documentation of this file. 
  1. BHSNRS ;IHS/MSC/MGH - Health Summary for NRS and imaging ;08-Dec-2010 13:34;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**4**;March 17, 2006;Build 13
  1.  ;==============================================================
  1.  ; IHS/CMI/LAB - PART 8 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
  1.  ;
  1. NRS ; ******************* NRS  - LAST 3  * 9000010.49 *******
  1.  ; <SETUP>
  1.  N BHSPAT,BHSCNT,BHSEX
  1.  S BHSPAT=DFN
  1.  Q:'$D(^AUPNVNTS("AA",BHSPAT))
  1.  ; <DISPLAY>
  1.  D NRDSP3
  1.  ; <CLEANUP>
  1.  K BHST,BHSFN
  1. NRS3X K BHST,BHSTX,BHSTL,BHSIVD,BHSDFN,BHSRDG,BHSVDF,BHSDAT,BHSCNT,BHS,X,Y
  1.  K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSITE,BHRISK,BHSPR,BHSQ,BHSREF,BHSX,C,MIEN
  1.  Q
  1. NRDSP3 ;get NRS type
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W ?1,"DATE",?12,"PROVIDER",?32,"RISK",?72,"RD ",!?72,"REFERRAL",!!
  1.  S BHSCNT=0,BHSEX=0
  1.  F  S BHSEX=$O(^AUPNVNTS("AA",BHSPAT,BHSEX)) Q:BHSEX'=+BHSEX!($D(GMTSQIT))!(BHSCNT>3)  D
  1.  .S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVNTS("AA",BHSPAT,BHSEX,BHSIVD)) S BHSCNT=BHSCNT+1 Q:BHSIVD=""!(BHSCNT>3)!($D(GMTSQIT))  D NRDSP13
  1.  Q
  1. NRDSP13 ;get NRS test DFN
  1.  S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
  1.  S BHSDFN=0 F BHSQ=0:0 S BHSDFN=$O(^AUPNVNTS("AA",BHSPAT,BHSEX,BHSIVD,BHSDFN)) Q:'BHSDFN!(BHSCNT>3)!($D(GMTSQIT))  D NRDSP23
  1.  Q
  1. NRDSP23 ;compile data & display NRS test
  1.  S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X
  1.  Q:'$D(^AUPNVNTS(BHSDFN,0))
  1.  S BHSPR=$E($$VAL^XBDIQ1(9000010.49,BHSDFN,1204),1,18)
  1.  S BHSREF=$S($P(^AUPNVNTS(BHSDFN,0),U,15):"Yes",1:"No")
  1.  S BHRISK=$$VAL^XBDIQ1(9000010.49,BHSDFN,.14) I BHRISK]"" S BHRISK=BHRISK_": "
  1.  S C=0 I $P(^AUPNVNTS(BHSDFN,0),U,4) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Age 70+"
  1.  I $P(^AUPNVNTS(BHSDFN,0),U,5) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Nut Supp"
  1.  I $P(^AUPNVNTS(BHSDFN,0),U,6) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Weight"
  1.  I $P(^AUPNVNTS(BHSDFN,0),U,7) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Diagnosis"
  1.  I $P(^AUPNVNTS(BHSDFN,0),U,8) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Appetite"
  1.  I $P(^AUPNVNTS(BHSDFN,0),U,9) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Diff Chew"
  1.  I $P(^AUPNVNTS(BHSDFN,0),U,10) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Food Aller/Intol"
  1.  I $P(^AUPNVNTS(BHSDFN,0),U,11) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Vom/Diarr"
  1.  I $P(^AUPNVNTS(BHSDFN,0),U,12) S C=C+1 S:C>1 BHRISK=BHRISK_"; " S BHRISK=BHRISK_"Other: "_$P(^AUPNVNTS(BHSDFN,0),U,13)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W ?1,BHSDAT,?12,BHSPR
  1.  K ^UTILITY($J,"W") S X=BHRISK,DIWL=0,DIWR=40 D ^DIWP
  1.  W ?32,^UTILITY($J,"W",0,1,0)
  1.  W ?74,BHSREF,!
  1.  F BHSX=2:1:$G(^UTILITY($J,"W",0)) D  Q:$D(GMTSQIT)
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W ?32,^UTILITY($J,"W",0,BHSX,0),!
  1.  K ^UTILITY($J)
  1.  Q
  1.  ;
  1. IMAGING ; EP FOR NEW COMPONENT
  1.  S BHSPAT=DFN
  1.  Q:'$D(^RADPT(BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  K BHSARR
  1.  D SVR(BHSPAT,$S(GMTSNDM=-1:9999999,1:GMTSNDM),$S(GMTSDLM=9999999:0,1:(9999999-GMTSDLM)),.BHSARR)
  1.  D PRINT(.BHSARR)
  1.  K BHSARR
  1.  Q
  1. SVR(DFN,MAX,START,LINE) ; RADIOLOGY REPORTS
  1.  I $G(DFN),$G(MAX),$G(START)]""
  1.  E  Q
  1.  N X,Y,Z,T,%,IDT,IDT2,EDT,GBL,PCC,RIEN,ARR,EXDT
  1.  N CASE,ESTAT,PRIEN,RCIEN,RDFN,RDOC,RSTAT,CNT,CPT,CPTIEN,MOD,PCE,PMIEN,PROC,TAB,TOT
  1.  S IDT=0,T="~",CNT=0
  1.  S IDT2=9999999-START
  1.  S GBL=$NA(^RADPT(DFN,"DT"))
  1. RPASS1 ;
  1.  F  Q:CNT>MAX  S IDT=$O(@GBL@(IDT)) Q:'IDT  Q:IDT>IDT2  D
  1.  . S EDT=+$G(@GBL@(IDT,0)) I 'EDT Q
  1.  . S EXDT=$$FMTE^XLFDT(EDT,2),EXDT=$TR(EXDT,"@"," "),EXDT=$P(EXDT,":",1,2)
  1.  . S RCIEN=0
  1.  . F  S RCIEN=$O(@GBL@(IDT,"P",RCIEN)) Q:'RCIEN  D
  1.  .. S X=$G(@GBL@(IDT,"P",RCIEN,0)) I X="" Q
  1.  .. S RIEN=$P(X,U,17) I RIEN="" Q
  1.  .. S RSTAT="",%=$P($G(^RARPT(RIEN,0)),U,5)
  1.  .. I $L(%) S RSTAT=$S(%="V":"VERIFIED",%="R":"RELEASED/NOT VERIFIED",%="PD":"PROBLEM DRAFT",%="D":"DRAFT",1:"")
  1.  .. S CNT=CNT+1 ; DONT WORRY ABOUT THE COUNT UNTIL THE NEXT DATE
  1.  .. S CASE=$P(X,U) I CASE="" Q
  1.  .. S ESTAT="",%=$P(X,U,3) ; NEEDS TRANSLATION
  1.  .. I % S ESTAT=$P($G(^RA(72,%,0)),U)
  1.  .. S RDFN=$P(X,U,15),RDOC=""
  1.  .. I RDFN S RDOC=$P($G(^VA(200,RDFN,0)),U)
  1.  .. S PRIEN=$P(X,U,2) I 'PRIEN Q
  1.  .. S Y=$G(^RAMIS(71,PRIEN,0)) I Y="" Q
  1.  .. S PROC=$P(Y,U) I PROC="" Q
  1.  .. S CPTIEN=+$P(Y,U,9)
  1.  .. S CPT=$P($G(^ICPT(CPTIEN,0)),U)
  1.  .. S MIEN=0,MOD=""
  1.  .. F  S MIEN=$O(@GBL@(IDT,"P",RCIEN,"M",MIEN)) Q:'MIEN  D
  1.  ... S PMIEN=+$G(@GBL@(IDT,"P",RCIEN,"M",MIEN,0)) I 'PMIEN Q
  1.  ... S %=$P($G(^RAMIS(71.2,PMIEN,0)),U) I %="" Q
  1.  ... I MOD'="" S MOD=MOD_", "
  1.  ... S MOD=MOD_%
  1.  ... Q
  1.  .. S ARR(CNT)=EXDT_T_PROC_T_MOD_T_CPT_T_RDOC_T_CASE_T_ESTAT_T_RSTAT
  1.  .. S Z=0
  1.  .. F  S Z=$O(@GBL@(IDT,"P",RCIEN,"H",Z)) Q:'Z  S ARR(CNT,"H",Z)=$G(@GBL@(IDT,"P",RCIEN,"H",Z,0)) ; HX
  1.  .. S Z=0
  1.  .. F  S Z=$O(^RARPT(RIEN,"R",Z)) Q:'Z  S ARR(CNT,"R",Z)=$G(^RARPT(RIEN,"R",Z,0)) ; REPORT
  1.  .. S Z=0
  1.  .. F  S Z=$O(^RARPT(RIEN,"I",Z)) Q:'Z  S ARR(CNT,"I",Z)=$G(^RARPT(RIEN,"I",Z,0)) ; IMPRESSION
  1.  .. Q
  1.  . Q
  1. RPASS2 ;
  1.  S ARR="HEADER"_T_"Procedure: "_T_"Procedure Modifier: "_T_"CPT Code: "_T_"Interpreting Staff: "_T_"Exam Case Number: "_T_"Exam Status: "_T_"Report Status: "
  1.  S CNT=0,LINE(1)="-----  IMAGING PROFILE  -----",LINE=1,TAB="  "
  1.  F  S CNT=$O(ARR(CNT)) Q:'CNT  D
  1.  . S TOT=$L(ARR(CNT),T) I 'TOT Q
  1.  . F PCE=1:1:TOT D
  1.  .. I PCE=1 S X=$P(ARR(CNT),T,1)_"  "_$P(ARR(CNT),T,2),PCE=2
  1.  .. E  S X=TAB_$P(ARR,T,PCE)_$P(ARR(CNT),T,PCE)
  1.  .. S LINE=LINE+1
  1.  .. S LINE(LINE)=X
  1.  .. Q
  1.  . S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
  1.  . S LINE(LINE)=TAB_"History: "
  1.  . S Z=0
  1.  . F  S Z=$O(ARR(CNT,"H",Z)) Q:'Z  D
  1.  .. S LINE=LINE+1
  1.  .. S LINE(LINE)=TAB_"  "_ARR(CNT,"H",Z)
  1.  .. Q
  1.  . S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
  1.  . S LINE(LINE)=TAB_"Report: "
  1.  . S Z=0
  1.  . F  S Z=$O(ARR(CNT,"R",Z)) Q:'Z  D
  1.  .. S LINE=LINE+1
  1.  .. S LINE(LINE)=TAB_"  "_ARR(CNT,"R",Z)
  1.  .. Q
  1.  . S LINE=LINE+1,LINE(LINE)=" ",LINE=LINE+1
  1.  . S LINE(LINE)=TAB_"Impression: "
  1.  . S Z=0
  1.  . F  S Z=$O(ARR(CNT,"I",Z)) Q:'Z  D
  1.  .. S LINE=LINE+1
  1.  .. S LINE(LINE)=TAB_"  "_ARR(CNT,"I",Z)
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ;
  1. PRINT(LINE) ; EP-PRINT RESULTS
  1.  N CNT
  1.  S CNT=0
  1.  F  S CNT=$O(LINE(CNT)) Q:'CNT  D  I $D(GMTSQIT) Q
  1.  . ;W !
  1.  . D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  . S X=$G(LINE(CNT))
  1.  . D WP(X)
  1.  . Q
  1.  Q
  1. WP(X) ;Do word wrap
  1.  N DIWF,DIWL,DIWR
  1.  S DIWF="",DIWL=0,DIWR=75
  1.  D ^DIWP
  1.  S RAX=0 F  S RAX=$O(^UTILITY($J,"W",DIWL,RAX)) Q:RAX'>0  D
  1.  .I RAX=1 W ?5,^UTILITY($J,"W",DIWL,RAX,0),!
  1.  .I RAX>1 W ?9,^UTILITY($J,"W",DIWL,RAX,0),!
  1.  K ^UTILITY($J,"W")
  1.  Q
  1.  ;