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

LR7OSUM1.m

Go to the documentation of this file. 
  1. LR7OSUM1 ;VA/DALOI/dcm - Silent Patient cum cont. ; Mar 11, 2003
  1.  ;;5.2;LAB SERVICE;**1003,1031**;NOV 1, 1997
  1.  ;
  1.  ;;VA LR Patche(s): 121,187,256,286,384
  1.  ;
  1. LRIDT ; from LR7OSUM
  1.  F  S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT)  I $D(^(LRIDT,0)) S X=^(0),CT1=CT1+1 D LRIIDT
  1.  Q
  1.  ;
  1. LRIIDT ;
  1.  S (LRIIDT,LRVIDT)=$P(X,U,1),LRSUB=1,LRTNN=1,LRSPM=$P(X,U,5),LRTLOC=$E($P(X,U,11),1,7),LRVDT=$P(X,U,3),LRAN=$P(X,U,6)
  1.  Q:'$L(LRVDT)
  1.  D LRSUB
  1.  Q
  1.  ;
  1.  ;
  1. LRSUB ;
  1.  N LRTRES
  1.  S LRSUB=1
  1.  F  S LRSUB=$O(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q:LRSUB<1  D
  1.  . S X=^LR(LRDFN,"CH",LRIDT,LRSUB)
  1.  . S LRTRES=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRSUB,"")
  1.  . D SUB1
  1.  Q
  1. SUB1 ;
  1.  S LRTSTVAL=$P(X,U,1),X1=$P(X,U,2)
  1.  S LRNOFL="",LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
  1.  Q:LRTST=""
  1.  Q:"IN"[$P(^LAB(60,LRTST,0),U,3)
  1.  I '$D(^LAB(64.5,"AC",LRSUB)) D MISC Q
  1.  K LRNON
  1.  D LRMH
  1.  I '$D(LRNON) D MISC
  1.  Q
  1.  ;
  1. LRMH ;
  1.  S LRMH=0
  1.  F  S LRMH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH)) Q:LRMH<1  D LRSH
  1.  Q
  1.  ;
  1. LRSH ;
  1.  S LRSH=0
  1.  F  S LRSH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH)) Q:LRSH<1  D TST
  1.  Q
  1.  ;
  1. TST ;
  1.  S LRTSTS=0
  1.  F  S LRTSTS=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS)) Q:'LRTSTS  S LRSPM1=^(LRTSTS) D TST1
  1.  Q
  1.  ;
  1.  ;
  1. TST1 ;
  1.  Q:LRSPM'=LRSPM1
  1. SBSET ;
  1.  S LRMHN=$P(^LAB(64.5,1,1,LRMH,0),U,1),LRTF=^(1,LRSH,0),$P(LRTF,U,4)=$P(LRTF,U,3),$P(LRTF,U,3)=$P(^(1,0),U,4),LRNON=1
  1.  Q:$S('$D(SUBHEAD):0,1:'$D(SUBHEAD($P(LRTF,"^"))))
  1.  ;
  1.  ;**  LRTE=Total minor headings
  1.  ;** LRMHN=Major heading name^TE^Lab performing tests
  1.  ;**  LRTF=Minor header^Profile specimen^Total tests^Type of display
  1.  ;
  1.  S LRIIDT=LRVIDT
  1.  S:'$D(^TMP($J,LRDFN,LRMH)) ^(LRMH)=LRMHN
  1.  S:'$D(^TMP($J,LRDFN,LRMH,LRSH))!($D(^(LRSH))=10) ^(LRSH)=LRTF_U
  1.  S:'$D(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,0)) ^(0)=LRTLOC_U_LRVIDT_U_LRVDT_U_LRAN_U_LRIDT
  1.  ;
  1. LRTSTVAL ;
  1.  ;
  1.  S ^TMP($J,LRDFN,LRMH,LRSH,LRIDT,LRTSTS)=$P(LRTRES,"^")_"^"_$P(LRTRES,"^",2)
  1.  S X=$P($G(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
  1.  I $L(X) S ^TMP("LRT",$J,X)=$P(LRTF,"^")
  1.  I $D(^LR(LRDFN,"CH",LRIDT,1,0)),'$D(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",0)) D TEXT
  1.  D CHKUN
  1.  I $O(^LAB(60,LRTST,1,LRSPM,1,0)),'$D(^TMP($J,"EVAL",LRTST,LRSPM)) D
  1.  . S ^TMP($J,"EVAL",LRTST,LRSPM)=""
  1.  . N I,L,X,TST
  1.  . S I=0,TST=$S($L($P($G(^LAB(60,LRTST,.1)),"^")):$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^"))
  1.  . S L=+$O(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1),L=L+1,^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)="Evaluation for "_TST_":"
  1.  . F  S I=$O(^LAB(60,LRTST,1,LRSPM,1,I)) Q:'I  S X=^(I,0) S L=L+1,^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=X
  1.  Q
  1.  ;
  1.  ;
  1. MISC ;
  1.  Q:$S('$D(SUBHEAD):0,1:'$D(SUBHEAD("MISCELLANEOUS TESTS")))
  1.  S LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
  1.  Q:LRTST=""
  1.  Q:"IN"[$P(^LAB(60,LRTST,0),U,3)
  1.  S LRTOP=LRSPM
  1.  ;
  1.  D ZEROFIX                             ; IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  S:'$D(^TMP($J,LRDFN,"MISC",LRIDT,0)) ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM
  1.  ;S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=LRTSTVAL_U_LRSPM_U_LRTST_U_X1_U_LRSUB
  1.  ; S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=$P(LRTRES,"^")_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1027
  1.  ;       If the result of the test is free text, it's possible that the
  1.  ;       the $L(LRTRES)>30, which is too wide for 80-char screen AND the
  1.  ;       text of the result needs to be wrapped.
  1.  S:$L($P(LRTRES,"^"))<31 ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=$P(LRTRES,"^")_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
  1.  I $L($P(LRTRES,"^"))>30 D
  1.  . NEW CRLF,LINE,RESULT,WRAPPED
  1.  . S RESULT(1)=$P(LRTRES,"^")
  1.  . D WRAP^BLRUTIL3("RESULT",29)
  1.  . S LINE=1
  1.  . S CRLF=$C(13)_$C(10)
  1.  . S WRAPPED=$G(^TMP("BLRUTIL3",$J,LINE,0))
  1.  . F  S LINE=$O(^TMP("BLRUTIL3",$J,LINE))  Q:LINE<1  D
  1.  .. S WRAPPED=WRAPPED_CRLF_$J("",49)_$G(^TMP("BLRUTIL3",$J,LINE,0))
  1.  . S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=WRAPPED_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
  1.  . K ^TMP("BLRUTIL3",$J)
  1.  ; ----- END IHS/OIT/MKK -- LR*5.2*1027
  1.  ;
  1.  S X=$S($D(^LAB(60,LRTST,.1)):$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^")),^TMP("LRT",$J,X)="MISCELLANEOUS TESTS"
  1.  ;
  1.  ; Grab specimen comments
  1.  I $D(^LR(LRDFN,"CH",LRIDT,1,0)),'$D(^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)) D
  1.  . S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)="",L=0
  1.  . ; F  S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:L<1  S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
  1.  . ; BEGIN -- IHS/OIT/MKK - LR*5.2*1027
  1.  . NEW ADDRFLAG
  1.  . S ADDRFLAG="NO"
  1.  . F  S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:L<1  D
  1.  .. S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
  1.  .. I $G(^LR(LRDFN,"CH",LRIDT,1,L,0))["Test Performed at" S ADDRFLAG="YES"
  1.  . ;
  1.  . I ADDRFLAG="YES" D
  1.  .. S L=1+$O(^LR(LRDFN,"CH",LRIDT,1,L),-1)
  1.  .. S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=" "   ; Put in extra "space" -- better readibility
  1.  . ; END -- IHS/OIT/MKK - LR*5.2*1027
  1.  ;
  1.  ; Grab test interpretation
  1.  I $O(^LAB(60,LRTST,1,LRSPM,1,0)) D
  1.  . N I,L,X,TST
  1.  . S I=0,TST=$S($L($P($G(^LAB(60,LRTST,.1)),"^")):$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^"))
  1.  . S:'$D(^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)) ^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)=""
  1.  . S L=+$O(^TMP($J,LRDFN,"MISC",LRIDT,"TX",9999999),-1),L=L+1
  1.  . S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)="Evaluation for "_TST_":"
  1.  . F  S I=$O(^LAB(60,LRTST,1,LRSPM,1,I)) Q:'I  S X=^(I,0) S L=L+1,^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=X
  1.  ;
  1.  S LRTNN=LRTNN+1
  1.  Q
  1.  ;
  1.  ;
  1. TEXT ;
  1.  S LRYESCOM=0
  1.  S M=0
  1.  F  S M=$O(^LR(LRDFN,"CH",LRIDT,1,M)) Q:M<1!(LRYESCOM)  F N=1:1:$L(^LR(LRDFN,"CH",LRIDT,1,M,0)) Q:LRYESCOM  S:$E(^(0),N)'[$C(32) LRYESCOM=1
  1.  Q:'LRYESCOM
  1.  S L=0
  1.  F  S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:L<1  S ^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
  1.  Q
  1.  ;
  1.  ;
  1. MICRO ;from LR7OSUM
  1.  Q:'$D(^LR(LRDFN,"MI"))
  1.  N MICROCNT
  1.  S:'$D(LRUNKNOW) LRUNKNOW=$P(^LAB(69.9,1,1),U,5)
  1.  S (LRONESPC,LRONETST)="",LREND=0,MICROCNT=GCNT+1
  1.  I $O(^LR(LRDFN,"MI",0)) S ^TMP("LRH",$J,"MICROBIOLOGY")=MICROCNT
  1.  S LRWRDVEW="",LRSB=0,LRIDT=LRIN
  1.  F  S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT)  S LRNLOC=LRLLOC,CT1=CT1+1 D EN1^LR7OSMZ0 S LRLLOC=LRNLOC
  1.  I GCNT'>MICROCNT K ^TMP("LRH",$J,"MICROBIOLOGY")
  1.  K %,A,A1,AGE,B,B1,DFN,DOB,DZ,I,J,LR2ORMOR,LRAA,LRACC,LRACN,LRAD,LRADM,LRADX,LRAFS,LRAX,LRBUG,LRCMNT,LRCS,LRDCOM,LREF,LREND,LRIFN,LRLLT,LRMD,LRNLOC,LRNS,LROK,LRONESPC,LRONETST,LRORG,LRPRE,LRPRINT
  1.  Q
  1.  ;
  1.  ;
  1. CHKUN ; Check units and normals with cumulative report values
  1.  ; Add comment if these differ from file #64.5 values
  1.  ;
  1.  N I,L,LRFLAG,LRHI,LRLO,LRLOHI,LRX,LRY,TST
  1.  S LRX=$G(^LAB(64.5,"A",1,LRMH,LRSH,LRTSTS)),LRFLAG=0
  1.  S TST=$P($G(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
  1.  S LRY="*** For test "_TST
  1.  ; Check units - if different generate comment
  1.  I $$UP^XLFSTR($P(LRX,"^",7))'=$$UP^XLFSTR($P(LRTRES,"^",5)) S LRY=LRY_" Units: "_$P(LRTRES,"^",5),LRFLAG=1
  1.  ;
  1.  ; Check normals - if different generate comment
  1.  S @("LRLO="_$S($P(LRX,"^",2)'="":$P(LRX,"^",2),$P(LRX,"^",11)'="":$P(LRX,"^",11),1:""""""))
  1.  ;
  1.  S @("LRHI="_$S($P(LRX,"^",3)'="":$P(LRX,"^",3),$P(LRX,"^",12)'="":$P(LRX,"^",12),1:""""""))
  1.  I LRLO'=$P(LRTRES,"^",3)!(LRHI'=$P(LRTRES,"^",4)) D
  1.  . ; check to see if these values are numeric and are different because of leading or trailing zeroes
  1.  . I '$$REALDIFF Q
  1.  . I LRFLAG S LRY=LRY_" and"
  1.  . S LRY=LRY_" Normals: "_$P(LRTRES,"^",3)_"-"_$P(LRTRES,"^",4),LRFLAG=1
  1.  ;
  1.  I 'LRFLAG Q
  1.  ;
  1.  S L=+$O(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1),L=L+1
  1.  S LRY=LRY_" ***",^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=LRY
  1.  Q
  1.  ;
  1.  ;
  1. REALDIFF() ;
  1.  ; function to determine if values are numeric and are different
  1.  ; solely because of leading or trailing zeroes
  1.  ;     returns 0 if difference is because of leading/trailing zeroes
  1.  ;     returns 1 if differences are meaningful
  1.  N LRTRESLO,LRTRESHI,DIFF
  1.  S LRTRESLO=$P(LRTRES,"^",3),LRTRESHI=$P(LRTRES,"^",4)
  1.  S DIFF=0
  1.  I LRLO'=LRTRESLO S DIFF=1 D
  1.  . I LRLO?.N!(LRLO?.N1".".N) D
  1.  . . I LRTRESLO?.N!(LRTRESLO?.N1".".N) D
  1.  . . . I +LRLO=+LRTRESLO S DIFF=0
  1.  I DIFF Q 1
  1.  I LRHI'=LRTRESHI S DIFF=1 D
  1.  . I LRHI?.N!(LRHI?.N1".".N) D
  1.  . . I LRTRESHI?.N!(LRTRESHI?.N1".".N) D
  1.  . . . I +LRHI=+LRTRESHI S DIFF=0
  1.  I DIFF Q 1
  1.  Q 0
  1.  ;
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1. ZEROFIX ; EP - Leading & Trailing Zero Fix for Results
  1.  Q:$L($P(LRTRES,"^"))<1                  ; Skip if no Result
  1.  ;
  1.  NEW DN,DP,ORIGRLST,RESULT,STR,SYMBOL
  1.  S DN=+$G(LRSUB)                         ; Data Name number
  1.  Q:DN<1                                  ; Skip if no Data Name number
  1.  ;
  1.  Q:$G(^DD(63.04,DN,0))'["^LRNUM"         ; Skip if no numeric defintiion
  1.  ;	
  1.  S STR=$P($P($G(^DD(63.04,DN,0)),"Q9=",2),$C(34),2)     ; Get numeric formatting
  1.  ;
  1.  S DP=+$P(STR,",",3)                     ; Decimal Places
  1.  Q:DP<1                                  ; Skip if no Decimal Defintion
  1.  ;
  1.  S RESULT=$P(LRTRES,"^")
  1.  ;
  1.  Q:$$UP^XLFSTR($G(RESULT))["SPECIMEN IN LAB"          ; Skip if not resulted
  1.  ;
  1.  S SYMBOL="",ORIGRSLT=RESULT
  1.  F  Q:$E(RESULT)="."!($E(RESULT)?1N)!(RESULT="")  D       ; Adjust if ANY Non-Numeric is at the beginning of RESULT
  1.  . S SYMBOL=SYMBOL_$E(RESULT)
  1.  . S RESULT=$E(RESULT,2,$L(RESULT))
  1.  ;
  1.  S:$E(RESULT)="." RESULT="0"_RESULT      ; Leading Zero Fix
  1.  ;
  1.  I $E(RESULT)'?1N  S RESULT=ORIGRSLT  Q  ; Skip if RESULT has no numeric part
  1.  ;
  1.  S RESULT=$TR($FN(RESULT,"P",DP)," ")
  1.  ;
  1.  S:$L($G(SYMBOL)) RESULT=SYMBOL_RESULT   ; Restore "symbol", if necessary
  1.  ;
  1.  S $P(LRTRES,"^",1)=RESULT
  1.  Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031