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

BLRALBA.m

Go to the documentation of this file. 
  1. BLRALBA ;VA/DALOI/RWF/BA-PRINT THE DATA FOR INTERIM REPORTS ;JUL 06, 2010 3:14 PM
  1.  ;;5.2;IHS LABORATORY;**1013,1015,1022,1025,1027**;NOV 01, 1997
  1.  ;
  1.  ;**Program Description**
  1.  ;  This program is copied from program, LRRP1 and
  1.  ;  modified to set the data into a temporary global
  1.  ;  instead of displaying on a report or to the screen.
  1.  ;
  1. PRINT S BLRADSP=0,$P(BLRABLKS," ",80)=""
  1.  S:'$L($G(SEX)) SEX="M" S:'$L($G(AGE)) AGE=99
  1.  S LRTC=$P(LR0,U,12)
  1.  S LRSPEC=+$P(LR0,U,5),X=$P(LR0,U,10) D DOC^LRX
  1.  S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Ordering Provider: "_LRDOC
  1.  S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,9)_"Specimen: "_$P($G(^LAB(61,LRSPEC,0)),U)
  1.  S LRAAO=0
  1. PORD S LRAAO=$O(^TMP("LR",$J,"TP",LRAAO)) G EXIT:LRAAO=""
  1.  D ORDER
  1.  G PORD
  1.  ;
  1. EXIT K ^TMP("LR",$J,"TP")
  1.  ;Q  ;IHS/ITSC/TPF 12/04/01 REMOVED PER MITRTEK
  1.  ;
  1.  S LRORU=$G(^LR(LRDFN,LRSS,LRIDT,"ORU")) Q:LRORU=""
  1.  I $D(^LRO(68,"C",LRORU)) D
  1.  . S LRAA=$O(^LRO(68,"C",LRORU,"")) Q:'LRAA
  1.  . S LRAD=$O(^LRO(68,"C",LRORU,LRAA,"")) Q:'LRAD
  1.  . S LRAN=$O(^LRO(68,"C",LRORU,LRAA,LRAD,"")) Q:'LRAN
  1.  ;
  1.  Q:+$G(LRAA)<1!(+$G(LRAD)<1)!(+$G(LRAN)<1)  ; IHS/OIT/MKK - LR*5.2*1027
  1.  ;
  1.  NEW TST
  1.  S TST=0
  1.  F  S TST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST)) Q:'TST  D
  1.  . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,5)="" D
  1.  .. S LRDN=$P($P($G(^LAB(60,TST,0)),U,5),";",2)
  1.  .. ; Do not combine the 3 if statements below into 1 ;DAOU/DJW 1/23/02
  1.  .. I '$D(LRDN) D PEND Q
  1.  .. I $G(LRDN)="" D PEND Q
  1.  .. I '$D(^LR(LRDFN,LRSS,LRIDT,LRDN)) D PEND Q
  1.  Q
  1.  ;
  1. PEND ; Set up this test to be displayed as pending 
  1.  S BLRAZ=$P($G(^LAB(60,TST,0)),U,1),BLRAZ1=30 D Z1
  1.  S BLRAZ=BLRAZ_"pending" D Z1
  1.  S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
  1.  Q
  1.  ;
  1. ORDER S LRCDT=0
  1. TST S LRCDT=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT)) Q:LRCDT=""
  1.  D TEST
  1.  G TST
  1. TEST S LRIDT=9999999-LRCDT,LRSS=$P($G(^TMP("LR",$J,"TP",LRAAO)),U,2)
  1.  ;
  1.  ;  Microbiology
  1.  I LRSS="MI" S LRH=1,LRHF=1,LRFOOT=0 K A,Z,LRH Q
  1.  ;
  1.  Q:'$P(LR0,U,3)
  1.  D ORU
  1.  D LIN
  1.  S Y=LRCDT D DD^LRX
  1.  S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,30)_Y
  1.  S BLRAZ=$E(BLRABLKS,1,5)_"Test name",BLRAZ1=30 D Z1
  1.  S BLRAZ=BLRAZ_"Result    units",BLRAZ1=21 D Z1
  1.  S BLRAZ=BLRAZ_$E(BLRABLKS,1,6)_"Ref.   range"
  1.  S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
  1.  ;
  1.  S LRPO=0 F  S LRPO=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)) Q:LRPO'>0  S LRDATA=^(LRPO) D DATA
  1.  I $D(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C")) D
  1.  . S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Comment: "
  1.  . S LRCMNT=0 F  S LRCMNT=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) Q:LRCMNT<1  D
  1.  .. S ^TMP($J,"BLRA",BLRADSP,0)=$G(^TMP($J,"BLRA",BLRADSP,0))_$G(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT))
  1.  .. I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,9)
  1.  Q
  1. DATA S LRTSTS=+LRDATA,LRPC=$P(LRDATA,U,5),LRSUB=$P(LRDATA,U,6)
  1.  S X=$P(LRDATA,U,7),LRFFLG=$P(LRDATA,U,8) Q:X=""
  1.  S BLRAZ=$S($L($P(LRDATA,U,2))>20:$P(LRDATA,U,3),1:$P(LRDATA,U,2))
  1.  S BLRAZ1=27 D Z1
  1.  ;
  1.  ;  If value to display is an executable
  1.  I LRPC'="" D
  1.  . S BLRAZZ="S X="_LRPC
  1.  . X BLRAZZ
  1.  . S LRPC=X
  1.  ;
  1.  S BLRAZ=BLRAZ_$S(LRPC="":$J(X,LRCW),1:LRPC)_" "_LRFFLG
  1.  S X=$S($D(^LAB(60,LRTSTS,1,LRSPEC,0)):^(0),1:"")
  1.  ;Q:'$L(X)
  1.  S LRTHER=$S($L($P(X,U,11,12))>1:1,1:0)
  1.  S LRLO=$S(LRTHER:$P(X,U,11),1:$P(X,U,2))
  1.   ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
  1.  I $G(LRLO)'["$"&($E($RE(LRLO),1,1)=".") S LRLO=$RE($P($RE(LRLO),".",2,999))
  1.  ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
  1.  S LRHI=$S(LRTHER:$P(X,U,12),1:$P(X,U,3))
  1.  ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
  1.  I $G(LRHI)'["$"&($E($RE(LRHI),1,1)=".") S LRHI=$RE($P($RE(LRHI),".",2,999))
  1.  ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
  1.  ; 
  1.  S @("LRLO="_$S($L(LRLO):LRLO,1:""""""))
  1.  S @("LRHI="_$S($L(LRHI):LRHI,1:""""""))
  1.  ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
  1.  ;      The changes that were implemented below DO NOT work if the
  1.  ;      reference ranges are $SELECT statements.  Therefore, they
  1.  ;      are being commented out.
  1.  ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022
  1.  ; The preceding two lines will fail with a <SYNTAX> error if the
  1.  ; LRLO or the LRHI variables end in periods; viz., 20.
  1.  ; 
  1.  ; In order to ensure that a variable that ends with a period does not
  1.  ; adversely effect any other code, the next two lines of code will
  1.  ; reset the LRLO and/or the LRHI variable, if necessary.
  1.  ; 
  1.  I $P(LRLO,".",2)="" S LRLO=$P(LRLO,".")
  1.  I $P(LRHI,".",2)="" S LRHI=$P(LRHI,".")
  1.  ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022
  1.  ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
  1.  ; 
  1.  S BLRAZ=BLRAZ,BLRAZ1=40 D Z1
  1.  S BLRAZ=BLRAZ_$P(X,U,7),BLRAZ1=51 D Z1
  1.  S BLRAZ=BLRAZ_$J(LRLO,4)_$S($L(LRHI):" - "_$J(LRHI,4),1:"")
  1.  S BLRAZ1=12 D Z1
  1.  S BLRAZ=BLRAZ_$S(LRTHER:"(Ther. range)",1:"")
  1.  S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
  1.  I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,0))>0 D
  1.  . S LRINTP=0
  1.  . F  S LRINTP=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)) Q:LRINTP<1  D
  1.  .. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,7)_"Eval: "_$G(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP))
  1.  Q
  1.  ;
  1. HDR ;EP
  1.  ; Header Information
  1.  I $G(BLRABLKS)="" S $P(BLRABLKS," ",80)=""
  1.  S LRHF=0,LRJ02=1,VALMHDR(1)=" "
  1.  I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") S VALMHDR(1)="** PERSONAL DATA - PRIVACY ACT OF 1974 **"
  1.  S BLRAZ=PNM,BLRAZ1=60 D Z1
  1.  S A8=$P($H,",",2),Y=A8\3600_":"_$E((A8\60#60+100),2,3)
  1.  S VALMHDR(2)=BLRAZ_$$FMTE^XLFDT(DT)_" "_Y
  1.  S VALMHDR(3)=$E(BLRABLKS,1,5)_"HRCN: "_HRCN_"    SEX: "_SEX_"    AGE: "_AGE_"    LOC: "_$G(LROC)
  1.  Q
  1.  ;
  1. ORU ; Display remote ordering info if available
  1.  N LRX
  1.  S LRX=$G(^LR(LRDFN,"CH",LRIDT,"ORU"))
  1.  S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="  Accession [UID]: "_$P(LR0,U,6)_" ["_$P(LRX,U)_"]"
  1.  I $P(LRX,U,2) D
  1.  . S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,2)="Ordering Site: "_$$EXTERNAL^DILFD(63.04,.32,"",$P(LRX,U,2))
  1.  . S BLRAZ=" Ordering Site UID: "_$P(LRX,U,5),BLRZ1=43 D Z1
  1.  . S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
  1.  I $P(LRX,U,3) D
  1.  . S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Collecting Site: "_$$EXTERNAL^DILFD(63.04,.33,"",$P(LRX,U,3))
  1.  Q
  1.  ;
  1. Z1 ;  Pad with trailing spaces
  1.  F BLRAI=1:1:(BLRAZ1-$L(BLRAZ)) S BLRAZ=BLRAZ_" "
  1.  Q
  1.  ;
  1. LIN ;EP
  1.  ; Set a Blank Line
  1.  S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=" "
  1.  Q