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

LRSRVR9A.m

Go to the documentation of this file. 
  1. LRSRVR9A ;BPFO/DTG - LAB NTRT DATA SERVER CONT'D MISSING VUID EXTRACT ;02/10/2016
  1.  ;;5.2;LAB SERVICE;**468**;FEB 10 2016;Build 64
  1.  ;
  1.  ; Based on LRSRVR2,LRSRVR2A
  1.  ;
  1. UUEN(STR) ; Uuencode string passed in.
  1.  N J,K,LEN,LRI,LRX,S,TMP,X,Y
  1.  S TMP="",LEN=$L(STR)
  1.  F LRI=1:3:LEN D
  1.  . S LRX=$E(STR,LRI,LRI+2)
  1.  . I $L(LRX)<3 S LRX=LRX_$E("   ",1,3-$L(LRX))
  1.  . S S=$A(LRX,1)*256+$A(LRX,2)*256+$A(LRX,3),Y=""
  1.  . F K=0:1:23 S Y=(S\(2**K)#2)_Y
  1.  . F K=1:6:24 D
  1.  . . S J=$$DEC^XLFUTL($E(Y,K,K+5),2)
  1.  . . S TMP=TMP_$C(J+32)
  1.  S TMP=$C(LEN+32)_TMP
  1.  Q TMP
  1.  ;
  1. TSTTYP(LRX) ; Determine test data type
  1.  N LRSTUB,LRTYPE,LRY
  1.  I LRX="" Q "|"
  1.  S LRX=$P(LRX,"(",2)
  1.  ;
  1.  ; Data type
  1.  S LRTYPE=$$GET1^DID($P(LRX,","),$P(LRX,",",2,99),"","TYPE")
  1.  S $P(LRSTUB,"|",2)=LRTYPE
  1.  ;
  1.  ; Input transform
  1.  S LRY=$$GET1^DID($P(LRX,","),$P(LRX,",",2,99),"",$S(LRTYPE="SET":"POINTER",1:"INPUT TRANSFORM"))
  1.  I LRTYPE="NUMERIC",LRY["LRNUM" D
  1.  . S LRX=$P(LRY,"""",2)
  1.  . I LRX?.1"-".N1","1.N1","1N S LRY="Number from "_$P(LRX,",")_" to "_$P(LRX,",",2)_" with "_$P(LRX,",",3)_" decimal"
  1.  S $P(LRSTUB,"|",1)=LRY
  1.  ; Help prompt
  1.  I LRTYPE="FREE TEXT" D
  1.   . S LRY=$$GET1^DID($P(LRX,","),$P(LRX,",",2,99),"","HELP-PROMPT")
  1.   . S $P(LRSTUB,"|",1)=LRY
  1.  Q LRSTUB
  1.  ;
  1. ENCODE(LRSTR) ; Encode a string, keep remainder for next line
  1.  ; Call with LRSTR by reference, Remainder returned in LRSTR
  1.  ;
  1.  S LRQUIT=0,LRLEN=$L(LRSTR)
  1.  F  D  Q:LRQUIT
  1.  . I $L(LRSTR)<45 S LRQUIT=1 Q
  1.  . S LRX=$E(LRSTR,1,45)
  1.  . S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN(LRX)
  1.  . S LRSTR=$E(LRSTR,46,LRLEN)
  1.  Q
  1.  ;
  1. MAILSEND(LRMSUBJ) ; Send extract back to requestor.
  1.  ;
  1.  N LRINSTR,LRTASK,LRTO,XMERR,XMZ
  1.  ;
  1.  ;ZEXCEPT: XQSND
  1.  ;
  1.  S LRTO(XQSND)=""
  1.  S LRINSTR("ADDR FLAGS")="R"
  1.  S LRINSTR("FROM")="LAB_PACKAGE"
  1.  S LRMSUBJ=$E(LRMSUBJ,1,65)
  1.  D SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK)
  1.  Q
  1.  ;
  1. CLEAN ;
  1.  K ^TMP($J,"LR60")
  1.  K ERR,LA7PCNT,LR60IEN,LR60NM,LR6421,LR64IEN
  1.  K LRACTION,LRCC,LRCCNX,LOINCDTA,LRRNLT,LRCDEF,LREND
  1.  K LRL,LRLNC,LRLNC80,LRLNCN,LRLNCX,LRNODE,LROUT,LROUT1,LRR64
  1.  K LRSPEC,LRSPEC60,LRSPECN,LRSPECTA,LRST,LRSTN,LRSTR,LRSTSYN
  1.  K LRTA,LRUNIT,LRX,LRY,X,Y,LRMISP
  1.  K LSITE,LRNT,LRNTI,AR,LRBLD,LRSUBSCRIPT,LRTYPER,LRTXT
  1.  K LRCDEF,LRCREATE,LREXPY,LRINACT,LRNODE,LRSPECCT,LA7TREE
  1.  D CLEAN^LRSRVR
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1.  ;
  1. HDR ; Set the header information
  1.  N XA S XA=""
  1.  S ^TMP($J,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT($$NOW^XLFDT)_" at "_LRSTN
  1.  S ^TMP($J,"LRDATA",2)="Report requested.......: "_LRSUB
  1.  S ^TMP($J,"LRDATA",3)="LOINC version..........: "_$$GET1^DID(95.3,"","","PACKAGE REVISION DATA")
  1.  S ^TMP($J,"LRDATA",4)="VistA File version.....: "_$G(^LAB(95.3,"VR"))
  1.  S ^TMP($J,"LRDATA",5)="Extract version........: 1.1"
  1.  F I=6,12,13 S ^TMP($J,"LRDATA",I)=" "
  1.  S ^TMP($J,"LRDATA",14)="Legend:"
  1.  S X="Station #-60 ien-Spec ien-Index|Test Name|Spec|Time Aspect|Units|Mapped LOINC|NLT #|Battery Code|Battery Description|Lab Section|Subscript|Comment|Data Type|Reference low|Reference high|Therapeutic low|Therapeutic high|"
  1.  S ^TMP($J,"LRDATA",15)=X,XA=$L(X)
  1.  ; S ^TMP($J,"LRDATA",17)=$$REPEAT^XLFSTR("-",$L(X))
  1.  ;S X="           1                  |    2    |  3 |     4     |  5  |  6  |  7  |    8       |     9             |     10    |   11    |   12  |    13   |     14      |     15       |      16       |       17       |"
  1.  ;S ^TMP($J,"LRDATA",16)=X
  1.  S X="Use Ref Lab|Site Comment|Test Synonyms|Test Type |MLTF 66.3 IEN|MLTF LOINC|MLTF Name|MLTF Alt Name|Default LOINC|Submitted to NTRT|Specimen Create Date|Extract Ver|"
  1.  ;S X="      18   |     19     |       20    |    21   |  22         |    23    |      24 |     25      |  26         |    27           |   28               |    29     |"
  1.  I LRMISP=1 D
  1.  . S X="Use Ref Lab|Site Comment|Test Synonyms|Test Type |MLTF 66.3 IEN|MLTF LOINC|MLTF Name|MLTF Alt Name|Default LOINC|Submitted to NTRT|Specimen Create Date| MISSING SPECIMENS|Extract Ver|"
  1.  . ;S X="      18   |     19     |       20    |    21   |  22         |    23    |      24 |     25      |  26         |    27           |   28               |    29            |     30    |"
  1.  S ^TMP($J,"LRDATA",16)=X,XA=XA+$L(X)
  1.  ;S ^TMP($J,"LRDATA",18)=X
  1.  ;S ^TMP($J,"LRDATA",18)=$$REPEAT^XLFSTR("-",$L(X))
  1.  I XA<245 S ^TMP($J,"LRDATA",17)=$$REPEAT^XLFSTR("-",XA)
  1.  I XA>245 S X=245,^TMP($J,"LRDATA",17)=$$REPEAT^XLFSTR("-",X)
  1.  S ^TMP($J,"LRDATA",18)=" "
  1.  I 'LRTXT D
  1.  . S LRFILENM=$TR(LRSTN," ","_")_"-"_LRSUB_"-"_$P($$FMTHL7^XLFDT($$NOW^XLFDT),"-")_".TXT"
  1.  . S ^TMP($J,"LRDATA",12)="Attached LMOF file.....: "_LRFILENM
  1.  . S ^TMP($J,"LRDATA",19)=$$UUBEGFN(LRFILENM)
  1.  K XA
  1.  Q
  1.  ;
  1.  ;
  1. SITENOTE ; Build site's test notes for first record
  1.  ;
  1.  N LRI,LRSTNDT
  1.  K LRSTNOTE
  1.  S (LRSTNOTE,LRI)=0
  1.  F  S LRI=$O(^LAB(60,LR60IEN,11,LRI)) Q:'LRI  D
  1.  . S LRSTNDT=$P($G(^LAB(60,LR60IEN,11,LRI,0)),"^")
  1.  . M LRSTNOTE(LRI)=^LAB(60,LR60IEN,11,LRI,1)
  1.  . S LRSTNOTE(LRI,1,0)=$S(LRI>1:"^",1:"")_$$FMTE^XLFDT(LRSTNDT,"1M")_": "_$G(LRSTNOTE(LRI,1,0))
  1.  . K LRSTNOTE(LRI,0)
  1.  I $D(LRSTNOTE) S LRSTNOTE=1
  1.  Q
  1.  ;
  1.  ;
  1. SUFFIX ; If Result NLT does not have a suffix, i.e. it has .0000 then check for suffixed NLT codes which can also be used
  1.  N LR64,LRRNLT,LRROOT,LRX,LRY
  1.  S LRRNLT=$$GET1^DIQ(64,LRR64_",",1,"E")
  1.  S LRROOT="^LAM(""E"","_LRRNLT_")"
  1.  F  S LRROOT=$Q(@LRROOT) Q:LRROOT=""  Q:$P($QS(LRROOT,2),".")'=$P(LRRNLT,".")  D
  1.  . S LR64=$QS(LRROOT,3)
  1.  . I $G(^LAM(LR64,5,LRSPEC60,0)) S LRSPEC(LRSPEC60_"-"_LR64)=LRSPEC60_U_LRSPECN_U_LRSPECTA_U_LRUNIT_U_LR64
  1.  Q
  1.  ;
  1.  ;
  1. UUBEGFN(LRFILENM) ; Construct uuencode "begin" coding
  1.  ; Call with LRFILENM = name of uuencoded file attachment
  1.  ; 
  1.  ; Returns LRX = string with "begin..."_file name
  1.  ;
  1.  N LRX
  1.  S LRX="begin 644 "_LRFILENM
  1.  Q LRX
  1.  ;
  1.  ; this is from LA7ADL1
  1. UNWIND(LA760,LA7URG,LA7PARNT) ; Unwind profile - set tests into array LA7TREE with urgency.
  1.  ;
  1.  ; Call with  LA760 = file #60 ien
  1.  ;           LA7URG = file #62.05 ien
  1.  ;         LA7PARNT = file #60 ien -  ordered parent (panel)
  1.  ;
  1.  ; Recursive panel, caught in a loop.
  1.  I $G(LA7PCNT)>50 Q
  1.  ;
  1.  ; If no urgency, set to routine (9), default value.
  1.  I 'LA7URG S LA7URG=9
  1.  ;
  1.  ; Test does not exist in file 60.
  1.  I '$D(^LAB(60,LA760,0)) Q
  1.  ;
  1.  ; Bypass "workload" type tests.
  1.  I $P(^LAB(60,LA760,0),"^",4)="WK" Q
  1.  ;
  1.  ; Test already listed, check if urgency different.
  1.  I $D(LA7TREE(LA760)) D  Q
  1.  . S LA7PCNT=0
  1.  . ; Convert expanded panel test urgency to regular urgency
  1.  . I LA7URG>50 S LA7URG=LA7URG-50
  1.  . ; Found test with higher urgency, save new urgency.
  1.  . I LA7URG<LA7TREE(LA760) S $P(LA7TREE(LA760),"^")=LA7URG
  1.  ;
  1.  ; Not a panel, list test with urgency.
  1.  I '$O(^LAB(60,LA760,2,0)) S LA7TREE(LA760)=LA7URG_"^"_LA7PARNT,LA7PCNT=0 Q
  1.  ;
  1.  N I
  1.  ;
  1.  ; Increment panel and test loop counter.
  1.  S LA7PCNT=$G(LA7PCNT)+1,I=0
  1.  ;
  1.  ; Expand test on panel.
  1.  F  S I=$O(^LAB(60,LA760,2,I)) Q:'I  D
  1.  . N II
  1.  . ; IEN of test on panel.
  1.  . S II=+$G(^LAB(60,LA760,2,I,0))
  1.  . ; Recursive panel, panel calls itself.
  1.  . I II,II=LA760 Q
  1.  . I II D UNWIND(II,LA7URG,LA7PARNT)
  1.  ;
  1.  Q