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

LR7OGMP.m

Go to the documentation of this file. 
  1. LR7OGMP ;VA/DALOI/STAFF- Interim report rpc memo print ; 03-Jul-2014 07:41 ; MKK
  1.  ;;5.2;LAB SERVICE;**1027,1031,1033**;NOV 01, 1997;Build 146
  1.  ;
  1.  ;;VA LR Patche(s): 187,246,282,286,344,395
  1.  ;
  1. PRINT(OUTCNT) ; from LR7OGMC
  1.  NEW ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,HIGH,IDT,INTP,LINE,LOW,LRCW,LRX,PORDER,PRNTCODE
  1.  NEW RANGE,REFHIGH,REFLOW,SEX,SITE,SPEC,SUB,TESTNUM
  1.  NEW TESTSPEC,THER,THERHIGH,THERLOW,UNITS,VALUE,X,ZERO
  1.  ;
  1.  NEW LRPLS,TIDT,SITECNT           ; IHS/OIT/MKK - LR*5.2*1027
  1.  ;
  1.  ; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges
  1.  S AGE=$P(^TMP("LR7OG",$J,"G"),U,4),SEX=$P(^("G"),U,5),LRCW=$P(^("G"),U,6)
  1.  S CDT=0
  1.  S SITECNT=0                      ; IHS/OIT/MKK - LR*5.*1027
  1.  F  S CDT=$O(^TMP("LR7OG",$J,"TP",CDT)) Q:CDT=""  D
  1.  . S IDT=9999999-CDT
  1.  . S ZERO=$S($D(^TMP("LR7OG",$J,"TP",CDT))#2:^(CDT),1:"")
  1.  . S SPEC=+$P(ZERO,U,5)
  1.  . S DOC=$$NAME(+$P(ZERO,U,10))
  1.  . D SETLINE("",.OUTCNT)
  1.  . S LINE="Report Released Date/Time: "_$$FMTE^XLFDT($P(ZERO,"^",3),"M")
  1.  . D SETLINE(LINE,.OUTCNT)
  1.  . S LINE="Provider: "_DOC
  1.  . D SETLINE(LINE,.OUTCNT)
  1.  . S LINE="  Specimen: "_$P($G(^LAB(61,SPEC,0),"<no specimen on file>"),U)_"."
  1.  . S ACC=$P(ZERO,U,6)
  1.  . S LINE=$$SETSTR^VALM1(" "_ACC,LINE,30,1+$L(ACC))
  1.  . D SETLINE(LINE,.OUTCNT)
  1.  . D SETLINE("    Specimen Collection Date: "_$$LRUDT^LR7OSUM6(CDT),.OUTCNT)
  1.  . ; D SETLINE("     Test name                Result    units      Ref.   range   Site Code",.OUTCNT)
  1.  . ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  . D SETLINE(" ",.OUTCNT)
  1.  . D SETLINE("                          Res",.OUTCNT)
  1.  . D SETLINE("Test name          Result Flg units        Ref.   range     Site  Result Dt/Time",.OUTCNT)
  1.  . ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  . S PORDER=0
  1.  . F  S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0  S DATA=^(PORDER) D
  1.  .. I $P(DATA,U,7)="" Q
  1.  .. S TESTNUM=+DATA,PRNTCODE=$P(DATA,U,5),SUB=$P(DATA,U,6),FLAG=$P(DATA,U,8),X=$P(DATA,U,7),UNITS=$P(DATA,U,9),RANGE=$P(DATA,U,10),SITE=$P(DATA,U,11)
  1.  .. S:+$G(SITE) SITECNT=SITECNT+1      ; IHS/OIT/MKK - LR*5.*1027
  1.  .. S LOW=$P(RANGE,"-"),HIGH=$P(RANGE,"-",2),THER=$P(DATA,U,12)
  1.  .. ;
  1.  .. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  .. ; NEW REFLOW,REFHIGH
  1.  .. ; S REFLOW=$$TRIM^XLFSTR($P($G(RANGE),"-"),"LR"," ")
  1.  .. ; S REFHIGH=$$TRIM^XLFSTR($P($G(RANGE),"-",2),"LR"," ")
  1.  .. ; D:$L(REFLOW) ZEROFIX(TESTNUM,.REFLOW)
  1.  .. ; D:$L(REFHIGH) ZEROFIX(TESTNUM,.REFHIGH)
  1.  .. ; I $L(REFLOW)!($L(REFHIGH)) S RANGE=$$EN^LRLRRVF(REFLOW,REFHIGH)
  1.  .. ; K REFLOW,REFHIGH
  1.  .. ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  .. ;
  1.  .. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
  1.  .. NEW REFLOW,REFHIGH
  1.  .. I $$UP^XLFSTR(RANGE)'["REF:" D
  1.  ... S REFLOW=$$TRIM^XLFSTR($P($G(RANGE),"-"),"LR"," ")
  1.  ... S REFHIGH=$$TRIM^XLFSTR($P($G(RANGE),"-",2),"LR"," ")
  1.  ... D:$L(REFLOW) ZEROFIX(TESTNUM,.REFLOW)
  1.  ... D:$L(REFHIGH) ZEROFIX(TESTNUM,.REFHIGH)
  1.  ... I $L(REFLOW)!($L(REFHIGH)) S RANGE=$$EN^LRLRRVF(REFLOW,REFHIGH)
  1.  ... K REFLOW,REFHIGH
  1.  .. I RANGE[" to "&(RANGE["Ref:") S RANGE=$P(RANGE,"Ref: ",2)
  1.  .. ; ----- END IHS/MSC/MKK - LR*5.2*1033
  1.  .. ;
  1.  .. ; I $L($P(DATA,U,2))>28,$P(DATA,U,3)'="" S LINE=$P(DATA,U,3)
  1.  .. ; E  S LINE=$E($P(DATA,U,2),1,28)
  1.  .. S LINE=$S($L($P(DATA,U,2))>15:$P(DATA,U,3),1:$P(DATA,U,2))       ; IHS/MSC/MKK - LR*5.2*1031
  1.  .. ; S LINE=$$SETSTR^VALM1("",LINE,28,0)
  1.  .. S LINE=$$SETSTR^VALM1("",LINE,17,0)                              ; IHS/MSC/MKK - LR*5.2*1031
  1.  .. ; I PRNTCODE="" S LINE=LINE_$J(X,8)
  1.  .. ; E  S @("VALUE="_PRNTCODE),LINE=LINE_VALUE
  1.  .. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  .. I PRNTCODE="" S VALUE=X
  1.  .. I PRNTCODE'="" S @("VALUE="_PRNTCODE)
  1.  .. S LINE=$$SETSTR^VALM1($J(VALUE,7),LINE,19,8)
  1.  .. ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  .. S LINE=LINE_" "_FLAG
  1.  .. ; I $L(LINE)>38 D SETLINE(LINE,.OUTCNT) S LINE=""
  1.  .. ; I UNITS'="" S LINE=$$SETSTR^VALM1("  "_UNITS,LINE,39,2+$L(UNITS))
  1.  .. I UNITS'="" S LINE=$$SETSTR^VALM1(UNITS,LINE,31,2+$L(UNITS))     ; IHS/OIT/MKK - LR*5.2*1027
  1.  .. I $G(RANGE)["$S(" D MUMPRNGE(.RANGE)                             ; IHS/OIT/MKK - LR*5.2*1027
  1.  .. S LRX=RANGE
  1.  .. ; I LRX'="" S LINE=$$SETSTR^VALM1(LRX,LINE,52,$L(LRX))
  1.  .. I LRX'="" S LINE=$$SETSTR^VALM1(LRX,LINE,44,$L(LRX))             ; IHS/OIT/MKK - LR*5.2*1027
  1.  .. ; I $L(LINE)>67,SITE D SETLINE(LINE,.OUTCNT) S LINE=""
  1.  .. ; I SITE S LINE=$$SETSTR^VALM1(" ["_SITE_"]",LINE,68,3+$L(SITE))
  1.  .. I SITE S LINE=$$SETSTR^VALM1($J("["_SITE_"]",7),LINE,59,7)       ; IHS/OIT/MKK - LR*5.2*1027
  1.  .. I IDT S LINE=$$SETSTR^VALM1($TR($$FMTE^XLFDT($P($G(^LR(LRDFN,"CH",IDT,0)),"^",3),"2MZ"),"@"," "),LINE,67,14) ; IHS/OIT/MKK - LR*5.2*1027
  1.  .. I LINE'="" D SETLINE(LINE,.OUTCNT)
  1.  .. I $O(^TMP("LR7OG",$J,"TP",CDT,PORDER,0))>0 D
  1.  ... S INTP=0
  1.  ... F  S INTP=+$O(^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)) Q:INTP<1  D SETLINE("      Eval: "_^(INTP),.OUTCNT)
  1.  . I $D(^TMP("LR7OG",$J,"TP",CDT,"C")) D
  1.  .. S LINE="Comment: "
  1.  .. S CMNT=0
  1.  .. F  S CMNT=+$O(^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)) Q:CMNT<1  S LINE=LINE_^(CMNT) D
  1.  ... D SETLINE(LINE,.OUTCNT)
  1.  ... I $O(^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)) S LINE="        "
  1.  . ; D SETLINE("===============================================================================",.OUTCNT)
  1.  . D:SITECNT<1 SETLINE($TR($J("",81)," ","="),.OUTCNT)               ; IHS/OIT/MKK - LR*5.2*1027
  1.  . ; D SETLINE(" ",.OUTCNT)
  1.  . D:SITECNT>0 PLS                                                   ; IHS/MSC/MKK - LR*5.2*1031
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
  1. MUMPRNGE(RANGE) ; EP -- MUMPS Code in Reference Range -- Evaluate and store
  1.  NEW LOW,HIGH,RV1,RV2
  1.  ;
  1.  S LOW=$$TRIM^XLFSTR($P(RANGE,"-"),"LR"," ")
  1.  S HIGH=$$TRIM^XLFSTR($P(RANGE,"-",2),"LR"," ")
  1.  ;
  1.  I $G(LOW)=""&($G(HIGH)="") S RANGE=" "  Q
  1.  ;
  1.  S RV1=$$MUMPEVAL(LOW)
  1.  S RV2=$$MUMPEVAL(HIGH)
  1.  ;
  1.  ; I $G(RV1)=""&($G(RV2)="")  S RANGE=" "  Q
  1.  ;
  1.  ; S RANGE=RV1_" - "_RV2
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  D:$L(RV1) ZEROFIX(TESTNUM,.RV1)
  1.  D:$L(RV2) ZEROFIX(TESTNUM,.RV2)
  1.  S RANGE=$$EN^LRLRRVF(RV1,RV2)       ; IHS/MSC/MKK - LR*5.2*1031
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  Q
  1.  ;
  1. MUMPEVAL(EVAL) ; 
  1.  NEW STR,WOT
  1.  ;
  1.  ; If no SELECT, just Return the string, BUT ... if the string contains punctuation, that means the
  1.  ; reference range code has been mis-parsed.  Return NULL.
  1.  I EVAL'["$S(" D  Q EVAL
  1.  .  I EVAL["("!(EVAL["?")!(EVAL["<")!(EVAL[")")!(EVAL["&") S EVAL=""
  1.  ;
  1.  ; If there is an "(" in the string, but no ")", that means the reference range code is too complex
  1.  ; and/or has been mis-parsed.  Return NULL.
  1.  I EVAL'[")" Q ""
  1.  ;
  1.  S STR="WOT="_EVAL
  1.  S @STR
  1.  ;
  1.  ; ANY punctuation in string means parsing failed.  Return NULL.
  1.  I WOT["("!(WOT["?")!(WOT["<")!(WOT[")")!(WOT["&") S WOT=""
  1.  ;
  1.  Q WOT
  1.  ;
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1027
  1.  ;
  1. SETLINE(LINE,CNT) ;
  1.  S ^TMP("LR7OGX",$J,"OUTPUT",CNT)=LINE
  1.  S CNT=CNT+1
  1.  Q
  1.  ;
  1.  ;
  1. NAME(X) ; $$(#) -> name
  1.  N LRDOC
  1.  D DOC^LRX
  1.  Q LRDOC
  1.  ;
  1.  ;
  1. DD(Y) ; $$(date/time) -> date/time format
  1.  D DD^LRX
  1.  Q Y
  1.  ;
  1.  ;
  1. PLS ; List performing laboratories
  1.  ;
  1.  N LINE,LRPLS,X
  1.  D SETLINE(" ",.OUTCNT)                                              ; IHS/OIT/MKK -- LR*5.2*1027
  1.  D SETLINE("Performing Lab Sites",.OUTCNT)
  1.  S LRPLS=0
  1.  F  S LRPLS=$O(^TMP("LRPLS",$J,LRPLS)) Q:LRPLS<1  D
  1.  . S LINE=$$LJ^XLFSTR("["_LRPLS_"] ",8)_$$NAME^XUAF4(LRPLS)
  1.  . D SETLINE(LINE,.OUTCNT)
  1.  . S X=$$PADD^XUAF4(LRPLS)
  1.  . S LINE=$$REPEAT^XLFSTR(" ",8)_$P(X,U)_"  "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4)
  1.  . D SETLINE(LINE,.OUTCNT)
  1.  ;
  1.  D SETLINE("===============================================================================",.OUTCNT)
  1.  ;
  1.  K ^TMP("LRPLS",$J)
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1. ZEROFIX(F60PTR,RESULT) ; EP - Leading & Trailing Zero Fix for Results
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,F60PTR,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,RESULT,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$UP^XLFSTR($G(RESULT))["SPECIMEN IN LAB"          ; Skip if not resulted
  1.  ;
  1.  Q:$L($G(RESULT))<1                      ; Skip if no Result
  1.  Q:$L($G(F60PTR))<1                      ; Skip if no File 60 Pointer
  1.  ;
  1.  S DN=+$G(^LAB(60,F60PTR,.2))
  1.  Q:DN<1                                  ; Skip if no DataName
  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 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.  Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031