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

BHSLABB.m

Go to the documentation of this file. 
  1. BHSLABB ;IHS/CIA/MGH - Health Summary for V lab file ;30-May-2014 15:46;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,9**;March 17, 2006;Build 16
  1.  ;===================================================================
  1.  ;Taken from APCHS3B
  1.  ; IHS/TUCSON/LAB - PART 3A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;  [ 02/21/03  6:43 AM ]
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**5,10**;JUN 24, 1997
  1.  ;====================================================================
  1.  ;IHS/MSC/MGH Updated with patch 13 changes
  1.  ;Patch 2 for patch 16 changes
  1.  ;Patch 3 updated for result date/time
  1.  ;=============================================================
  1.  ;CHANGED TO REVERSE CHRONOLOGICAL ORDER
  1. MRL ; ******************** MOST RECENT LAB * 9000010.09 *******
  1.  N BHSPAT,D,X,BHSQ,APCHDATE
  1.  S BHSPAT=DFN
  1.  I '$D(^AUPNVLAB("AA",BHSPAT)) D EKGLAB S BHST="LAB",BHSFN=60 D DISPREF^BHSRAD G MRLX
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ; <SETUP>
  1.  ; <PROCESS>
  1.  D LBLD,LPRT1
  1.  D EKGLAB
  1.  ;now display lab refusals
  1.  S BHST="LAB",BHSFN=60 D DISPREF^BHSRAD
  1.  K BHST,BHSFN
  1.  ; <CLEANUP>
  1. MRLX K BHSLT,BHSLR,BHSX,BHSLTX,BHSLRT,BHSLL,BHSLW,BHSNMX,BHSDFN,BHSIVD,BHSLTD,BHSN,Y,BHSRDT,BHSLTX
  1.  K ^TMP($J,"BHS")
  1.  Q
  1.  ; <BUILD>
  1. LBLD K ^TMP($J,"BHS","LAB"),^TMP($J,"BHS1")
  1.  S BHSLRT="" F BHSQ=0:0 S BHSLRT=$O(^AUPNVLAB("AA",BHSPAT,BHSLRT)) Q:BHSLRT=""  D LDATE
  1.  D REORDER
  1.  Q
  1. REORDER ;reorder by accession, parent and child
  1.  N %,%1,%2
  1.  S X=0 F  S X=$O(^TMP($J,"BHS","LAB",X)) Q:X'=+X  D
  1.  .S Y=$P(^TMP($J,"BHS","LAB",X),U,3)
  1.  .S D=(9999999-$P(^TMP($J,"BHS","LAB",X),U,1))
  1.  .S %=$E($P(^AUPNVLAB(Y,0),U,6),1,2) S:%="" %="ZZ"
  1.  .S %1=$S($P($G(^AUPNVLAB(Y,12)),U,8)]"":$P(^AUPNVLAB(Y,12),U,8),1:Y)
  1.  .S %2=$S($P($G(^AUPNVLAB(Y,12)),U,8)="":0,1:Y)
  1.  .S ^TMP($J,"BHS1",D,%,%1,%2,X)=^TMP($J,"BHS","LAB",X)
  1.  .Q
  1.  K ^TMP($J,"BHS")
  1.  Q
  1.  ;OLD STUFF
  1.  ;S X=0 F  S X=$O(^TMP($J,"BHS","LAB",X)) Q:X'=+X  D
  1.  ;.S Y=$P(^TMP($J,"BHS","LAB",X),U,1)
  1.  ;.S ^TMP($J,"BHS1",9999999-Y,X)=^TMP($J,"BHS","LAB",X)
  1.  ;.Q
  1.  ;K ^TMP($J,"BHS")
  1.  ;Q
  1. LDATE S BHSIVD=$O(^AUPNVLAB("AA",BHSPAT,BHSLRT,0)) S BHSDFN=$O(^(BHSIVD,0)) D:BHSIVD&(BHSIVD'>GMTSDLM) LSET
  1.  Q
  1. LSET ;
  1.  S BHSN=^AUPNVLAB(BHSDFN,0),BHSLR=$P(BHSN,U,4)
  1.  I $P($G(^AUPNVLAB(BHSDFN,11)),U,9)="R",BHSLR="",$$VALI^XBDIQ1(60,$P(BHSN,U),999999901) Q  ;do not display tests that are resulted, result is null and flag says don't display
  1.  ;IHS/MSC/MGH patch 13 change entered
  1.  I BHSLR]"",BHSLR'="",$P(BHSN,U,5)]"" S BHSLR=BHSLR_" ("_$P(BHSN,U,5)_")"
  1.  ;Added patch 3
  1.  I BHSLR="",$P($G(^TMP($J,"BHS","LAB",BHSLRT)),U,2)]"" Q
  1.  S ^TMP($J,"BHS","LAB",BHSLRT)=(-BHSIVD\1+9999999)_U_BHSLR_U_BHSDFN S BHSLTX=$P(^LAB(60,BHSLRT,0),U,1)
  1.  Q
  1.  ; <PRINT>
  1. LPRT1 ;ALTERNATE ROUTE IHS/OKCAO/POC 1/20/00
  1.  ;W ?52,"UNITS",?60,"REF RANGE",!
  1.  W ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?50,"RESULT",?60,"UNITS",?70,"REF RANGE",!
  1.  S APCHDATE="" F  S APCHDATE=$O(^TMP($J,"BHS1",APCHDATE)) Q:APCHDATE=""!($D(GMTSQIT))  D LPRT11
  1.  Q
  1. LPRT11 ;
  1.  S BHSACC="" F  S BHSACC=$O(^TMP($J,"BHS1",APCHDATE,BHSACC)) Q:BHSACC=""!($D(GMTSQIT))  D
  1.  .S BHSPAR=0 F  S BHSPAR=$O(^TMP($J,"BHS1",APCHDATE,BHSACC,BHSPAR)) Q:BHSPAR'=+BHSPAR!($D(GMTSQIT))  D
  1.  ..S APCHCHIL="" F  S APCHCHIL=$O(^TMP($J,"BHS1",APCHDATE,BHSACC,BHSPAR,APCHCHIL)) Q:APCHCHIL=""  D
  1.  ...S BHSLT=$O(^TMP($J,"BHS1",APCHDATE,BHSACC,BHSPAR,APCHCHIL,0))
  1.  ...S BHSDFN=$P(^TMP($J,"BHS1",APCHDATE,BHSACC,BHSPAR,APCHCHIL,BHSLT),U,3)
  1.  ...S X=$P(^TMP($J,"BHS1",APCHDATE,BHSACC,BHSPAR,APCHCHIL,BHSLT),U,1),BHSLR=$P(^TMP($J,"BHS1",APCHDATE,BHSACC,BHSPAR,APCHCHIL,BHSLT),U,2) D REGDT4^GMTSU S BHSLTD=X
  1.  ...D LPRT2
  1.  K APCHCHIL,BHSPAR,BHSACC,BHSLT
  1.  Q
  1. LPRT2 ;
  1.  S BHSLTX=$P(^LAB(60,BHSLT,0),U)
  1.  S BHSRDT=$P($G(^AUPNVLAB(BHSDFN,12)),U,12) I BHSRDT]"" S BHSRDT=$$DATE^APCHSMU($P(BHSRDT,"."))_"@"_$P($P($$FMTE^XLFDT(BHSRDT),"@",2),":",1,2)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  I GMTSNPG W ?2,"TEST",?23,"RESULT DT/TIME",?39,"VISIT",?47,"RESULT",?60,"UNITS",?70,"REF RANGE",!
  1.  W:APCHCHIL "  " W $E(BHSLTX,1,20),?23,BHSRDT,?39,BHSLTD,?50,BHSLR
  1.  W ?60,$P($G(^AUPNVLAB(BHSDFN,11)),U)
  1.  I $P($G(^AUPNVLAB(BHSDFN,11)),U)]"" W ?70,$P(^AUPNVLAB(BHSDFN,11),U,4)_"-"_$P(^AUPNVLAB(BHSDFN,11),U,5)
  1.  ;Patch 3, enter comments
  1.  S BHSX=0 F  S BHSX=$O(^AUPNVLAB(BHSDFN,21,BHSX)) Q:BHSX'=+BHSX!($D(GMTSQIT))  D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !,?1,^AUPNVLAB(BHSDFN,21,BHSX,0)
  1.  F BHSX=1:1:3 Q:$D(GMTSQIT)  I $P($G(^AUPNVLAB(BHSDFN,13)),U,BHSX)]"" D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !,$P(^AUPNVLAB(BHSDFN,13),U,BHSX)
  1.  W !
  1.  Q
  1.  ;
  1. EKGLAB ;ENTRY POINT - EKG display in most recent lab panel
  1.  Q:'$D(^AUPNVDXP("AC",BHSPAT))
  1.  K BHS
  1.  S BHSERR=$$START1^APCLDF(BHSPAT_"^LAST DIAGNOSTIC ECG SUMMARY","BHS(")
  1.  G:BHSERR EKGLABX
  1.  ; *array BHS(1)="DATE^RESULT^DIAG PROC^VDIAG PROCEDURE IEN^AUPNVDXP^VISIT IEN"
  1.  K BHSERR
  1.  S BHSIVD=$S($D(BHS(1)):9999999-$P($P(BHS(1),U,1),".",1),1:"")
  1.  Q:'BHSIVD!(BHSIVD>GMTSDLM)
  1.  S (BHSLTX,BHSLT)="EKG"
  1.  S BHSLRT("EKG")=$P(BHS(1),U,1)_"^"_$P(BHS(1),U,2)
  1.  D EKGPRT  ;                           computes/prints ekg info
  1. EKGLABX ;
  1.  K BHSERR,BHS(1)
  1.  Q
  1.  ;
  1. EKGPRT ;computers/prints ekg info
  1.  S X=$P(BHSLRT(BHSLT),U,1) D REGDT4^GMTSU S BHSLTD=X
  1.  S BHSLR=$P(BHSLRT(BHSLT),U,2)
  1.  S BHSLR=$S(BHSLR="N":"NORMAL",BHSLR="A":"ABNORMAL",BHSLR="B":"BORDERLINE",1:"<none recorded>") ;IHS/CMI/LAB added borderline
  1.  S BHSLW=$S($G(BHSLW):BHSLW,1:28)
  1.  W !,BHSLTX,?BHSLW,BHSLTD,"  ",BHSLR,!
  1.  Q
  1.  ;