- LRSRVR2A ;DALIO/FHS - LAB DATA SERVER CONT'D RELMA EXTRACT ; Aug 17, 2006
- ;;5.2;LAB SERVICE;**346**;Sep 27, 1994;Build 10
- ; Called by LRSRVR2
- ;
- ;
- CLEAN ;
- K ^TMP($J,"LR60")
- K ERR,LA7PCNT,LR60IEN,LR60NM,LR6421,LR64IEN
- K LRACTION,LRCC,LRCCNX,LOINCDTA,LRRNLT,LRCDEF,LREND
- K LRL,LRLNC,LRLNC80,LRLNCN,LRLNCX,LRNODE,LROUT,LROUT1,LRR64
- K LRSPEC,LRSPEC60,LRSPECN,LRSPECTA,LRST,LRSTN,LRSTR,LRSTSYN
- K LRTA,LRUNIT,LRX,LRY,X,Y
- D CLEAN^LRSRVR
- D ^%ZISC
- Q
- ;
- ;
- HDR ; Set the header information
- S ^TMP($J,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT($$NOW^XLFDT)_" at "_LRSTN
- S ^TMP($J,"LRDATA",2)="Report requested.......: "_LRSUB
- S ^TMP($J,"LRDATA",3)="LOINC version..........: "_$$GET1^DID(95.3,"","","PACKAGE REVISION DATA")
- S ^TMP($J,"LRDATA",4)="VistA File version.....: "_$G(^LAB(95.3,"VR"))
- S ^TMP($J,"LRDATA",5)="Extract version........: 1.1"
- F I=6,12,13 S ^TMP($J,"LRDATA",I)=" "
- S ^TMP($J,"LRDATA",14)="Legend:"
- S X="Station #-60 ien-Spec ien-Index|Test Name|Spec|Time Aspect|Units|LOINC|NLT #|Battery Code|Battery Description|Lab Section|Subscript|Comment|Data Type|Reference low|Reference high|Therapeutic low|Therapeutic high|"
- S ^TMP($J,"LRDATA",15)=X
- ;S X=" 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 |"
- ;S ^TMP($J,"LRDATA",16)=X
- S X="Use Ref Lab|Site Comment|Test Synonyms|Test Type|Default LOINC|Extract Ver|"
- S ^TMP($J,"LRDATA",16)=X
- ;S X=" 18 | 19 | 20 | 21 | 22 | 23 |"
- ;S ^TMP($J,"LRDATA",18)=X
- S ^TMP($J,"LRDATA",17)=$$REPEAT^XLFSTR("-",$L(X))
- S ^TMP($J,"LRDATA",18)=" "
- I 'LRTXT D
- . S LRFILENM=$TR(LRSTN," ","_")_"-"_LRSUB_"-"_$P($$FMTHL7^XLFDT($$NOW^XLFDT),"-")_".TXT"
- . S ^TMP($J,"LRDATA",12)="Attached LMOF file.....: "_LRFILENM
- . S ^TMP($J,"LRDATA",19)=$$UUBEGFN(LRFILENM)
- Q
- ;
- ;
- SITENOTE ; Build site's test notes for first record
- ;
- N LRI,LRSTNDT
- K LRSTNOTE
- S (LRSTNOTE,LRI)=0
- F S LRI=$O(^LAB(60,LR60IEN,11,LRI)) Q:'LRI D
- . S LRSTNDT=$P($G(^LAB(60,LR60IEN,11,LRI,0)),"^")
- . M LRSTNOTE(LRI)=^LAB(60,LR60IEN,11,LRI,1)
- . S LRSTNOTE(LRI,1,0)=$S(LRI>1:"^",1:"")_$$FMTE^XLFDT(LRSTNDT,"1M")_": "_$G(LRSTNOTE(LRI,1,0))
- . K LRSTNOTE(LRI,0)
- I $D(LRSTNOTE) S LRSTNOTE=1
- Q
- ;
- ;
- SYNNOTE ; Build site's test synonym's for first record
- ;
- K LRSTSYN
- S LRSTSYN=0
- M LRSTSYN=^LAB(60,LR60IEN,5)
- K LRSTSYN(0),LRSTSYN("B")
- I $D(LRSTSYN) S LRSTSYN=1
- Q
- ;
- ;
- 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
- N LR64,LRRNLT,LRROOT,LRX,LRY
- S LRRNLT=$$GET1^DIQ(64,LRR64_",",1,"E")
- S LRROOT="^LAM(""E"","_LRRNLT_")"
- F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$P($QS(LRROOT,2),".")'=$P(LRRNLT,".") D
- . S LR64=$QS(LRROOT,3)
- . I $G(^LAM(LR64,5,LRSPEC60,0)) S LRSPEC(LRSPEC60_"-"_LR64)=LRSPEC60_U_LRSPECN_U_LRSPECTA_U_LRUNIT_U_LR64
- Q
- ;
- ;
- UUBEGFN(LRFILENM) ; Construct uuencode "begin" coding
- ; Call with LRFILENM = name of uuencoded file attachment
- ;
- ; Returns LRX = string with "begin..."_file name
- ;
- N LRX
- S LRX="begin 644 "_LRFILENM
- Q LRX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSRVR2A 3269 printed Feb 18, 2025@23:46:41 Page 2
- LRSRVR2A ;DALIO/FHS - LAB DATA SERVER CONT'D RELMA EXTRACT ; Aug 17, 2006
- +1 ;;5.2;LAB SERVICE;**346**;Sep 27, 1994;Build 10
- +2 ; Called by LRSRVR2
- +3 ;
- +4 ;
- CLEAN ;
- +1 KILL ^TMP($JOB,"LR60")
- +2 KILL ERR,LA7PCNT,LR60IEN,LR60NM,LR6421,LR64IEN
- +3 KILL LRACTION,LRCC,LRCCNX,LOINCDTA,LRRNLT,LRCDEF,LREND
- +4 KILL LRL,LRLNC,LRLNC80,LRLNCN,LRLNCX,LRNODE,LROUT,LROUT1,LRR64
- +5 KILL LRSPEC,LRSPEC60,LRSPECN,LRSPECTA,LRST,LRSTN,LRSTR,LRSTSYN
- +6 KILL LRTA,LRUNIT,LRX,LRY,X,Y
- +7 DO CLEAN^LRSRVR
- +8 DO ^%ZISC
- +9 QUIT
- +10 ;
- +11 ;
- HDR ; Set the header information
- +1 SET ^TMP($JOB,"LRDATA",1)="Report Generated.......: "_$$FMTE^XLFDT($$NOW^XLFDT)_" at "_LRSTN
- +2 SET ^TMP($JOB,"LRDATA",2)="Report requested.......: "_LRSUB
- +3 SET ^TMP($JOB,"LRDATA",3)="LOINC version..........: "_$$GET1^DID(95.3,"","","PACKAGE REVISION DATA")
- +4 SET ^TMP($JOB,"LRDATA",4)="VistA File version.....: "_$GET(^LAB(95.3,"VR"))
- +5 SET ^TMP($JOB,"LRDATA",5)="Extract version........: 1.1"
- +6 FOR I=6,12,13
- SET ^TMP($JOB,"LRDATA",I)=" "
- +7 SET ^TMP($JOB,"LRDATA",14)="Legend:"
- +8 SET X="Station #-60 ien-Spec ien-Index|Test Name|Spec|Time Aspect|Units|LOINC|NLT #|Battery Code|Battery Description|Lab Section|Subscript|Comment|Data Type|Reference low|Reference high|Therapeutic low|Therapeutic high|"
- +9 SET ^TMP($JOB,"LRDATA",15)=X
- +10 ;S X=" 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 |"
- +11 ;S ^TMP($J,"LRDATA",16)=X
- +12 SET X="Use Ref Lab|Site Comment|Test Synonyms|Test Type|Default LOINC|Extract Ver|"
- +13 SET ^TMP($JOB,"LRDATA",16)=X
- +14 ;S X=" 18 | 19 | 20 | 21 | 22 | 23 |"
- +15 ;S ^TMP($J,"LRDATA",18)=X
- +16 SET ^TMP($JOB,"LRDATA",17)=$$REPEAT^XLFSTR("-",$LENGTH(X))
- +17 SET ^TMP($JOB,"LRDATA",18)=" "
- +18 IF 'LRTXT
- Begin DoDot:1
- +19 SET LRFILENM=$TRANSLATE(LRSTN," ","_")_"-"_LRSUB_"-"_$PIECE($$FMTHL7^XLFDT($$NOW^XLFDT),"-")_".TXT"
- +20 SET ^TMP($JOB,"LRDATA",12)="Attached LMOF file.....: "_LRFILENM
- +21 SET ^TMP($JOB,"LRDATA",19)=$$UUBEGFN(LRFILENM)
- End DoDot:1
- +22 QUIT
- +23 ;
- +24 ;
- SITENOTE ; Build site's test notes for first record
- +1 ;
- +2 NEW LRI,LRSTNDT
- +3 KILL LRSTNOTE
- +4 SET (LRSTNOTE,LRI)=0
- +5 FOR
- SET LRI=$ORDER(^LAB(60,LR60IEN,11,LRI))
- if 'LRI
- QUIT
- Begin DoDot:1
- +6 SET LRSTNDT=$PIECE($GET(^LAB(60,LR60IEN,11,LRI,0)),"^")
- +7 MERGE LRSTNOTE(LRI)=^LAB(60,LR60IEN,11,LRI,1)
- +8 SET LRSTNOTE(LRI,1,0)=$SELECT(LRI>1:"^",1:"")_$$FMTE^XLFDT(LRSTNDT,"1M")_": "_$GET(LRSTNOTE(LRI,1,0))
- +9 KILL LRSTNOTE(LRI,0)
- End DoDot:1
- +10 IF $DATA(LRSTNOTE)
- SET LRSTNOTE=1
- +11 QUIT
- +12 ;
- +13 ;
- SYNNOTE ; Build site's test synonym's for first record
- +1 ;
- +2 KILL LRSTSYN
- +3 SET LRSTSYN=0
- +4 MERGE LRSTSYN=^LAB(60,LR60IEN,5)
- +5 KILL LRSTSYN(0),LRSTSYN("B")
- +6 IF $DATA(LRSTSYN)
- SET LRSTSYN=1
- +7 QUIT
- +8 ;
- +9 ;
- 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 NEW LR64,LRRNLT,LRROOT,LRX,LRY
- +2 SET LRRNLT=$$GET1^DIQ(64,LRR64_",",1,"E")
- +3 SET LRROOT="^LAM(""E"","_LRRNLT_")"
- +4 FOR
- SET LRROOT=$QUERY(@LRROOT)
- if LRROOT=""
- QUIT
- if $PIECE($QSUBSCRIPT(LRROOT,2),".")'=$PIECE(LRRNLT,".")
- QUIT
- Begin DoDot:1
- +5 SET LR64=$QSUBSCRIPT(LRROOT,3)
- +6 IF $GET(^LAM(LR64,5,LRSPEC60,0))
- SET LRSPEC(LRSPEC60_"-"_LR64)=LRSPEC60_U_LRSPECN_U_LRSPECTA_U_LRUNIT_U_LR64
- End DoDot:1
- +7 QUIT
- +8 ;
- +9 ;
- UUBEGFN(LRFILENM) ; Construct uuencode "begin" coding
- +1 ; Call with LRFILENM = name of uuencoded file attachment
- +2 ;
- +3 ; Returns LRX = string with "begin..."_file name
- +4 ;
- +5 NEW LRX
- +6 SET LRX="begin 644 "_LRFILENM
- +7 QUIT LRX