LRSRVR8 ; DALOI/JMC - LAB DATA SERVER - Utilities ;03/22/11 15:23
;;5.2;LAB SERVICE;**350,495**;Sep 27, 1994;Build 6
;
; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*495; Jul 10 2017
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
LOAD ; Load mapping file into VistA as file server for distribution to other sites.
;
N LRFILE,LRRECORDFORMAT,LRMAILGROUP,LRMAILGROUPXQA,LRMAPPINGFILE,LRTYPE,PWD
K ^TMP($J)
;
D TYPE(1)
I LRTYPE<1 Q
;
; Select/get mapping file
D GETFILE
I LRFILE="" Q
;
; Load file into TMP global
D LOADFILE
;
; Process file from TMP global into file #95.4
I $D(^TMP($J,"LRMAP")) D IMPORT(LRTYPE)
Q
;
;
LOADSCT ; Load SCT mapping file into VistA and apply mapping.
; Called by option LA7S LOAD MAPPING SCT to load and apply mapping directly at the site.
;
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,LRACTION,LRFILE,LRMAILGROUP,LRMAPPINGFILE,LRRECORDFORMAT,LRTYPE,PWD,X,Y
K ^TMP($J)
; START OF CHANGE FOR LR*5.2*495
;S LRTYPE=2,LRTYPE(0)="SCT",LRACTION=1
S LRTYPE=2,LRTYPE(0)="SCT",LRACTION=0
I '$D(^LAHM(95.4,"AF","SCT")) D Q
. K DIR,DIRUT,DIROUT,DTOUT,DUOUT
. S DIR(0)="E",DIR("A",1)="No SNOMED CT codes loaded in LAB MAPPING file",DIR("A")="Press any key to continue"
. D ^DIR
;
; END OF CHANGE FOR LR*5.2*495 #1
;
; Ask if just processing exiting entries and/or load a file.
I $D(^LAHM(95.4,"AF","SCT")) D
. K DIR,DIRUT,DIROUT,DTOUT,DUOUT
. ; START OF CHANGE FOR LR*5.2*495
. ;S DIR(0)="SO^1:Load file;2:Process previous loaded file",DIR("B")="2"
. S DIR(0)="SO^0:Quit - no action;2:Process previous loaded file",DIR("B")="2"
. ; END OF CHANGE FOR LR*5.2*495 #2
. D ^DIR
. I Y<1 S LRACTION=0 Q
. S LRACTION=+Y
;
I LRACTION<1 Q
;
I LRACTION=1 D
. D GETFILE ; Select/get mapping file
. I LRFILE="" Q
. ;
. D LOADFILE ; Load file into TMP global
. I '$D(^TMP($J,"LRMAP")) Q
. ;
. D IMPORT(LRTYPE) ; Process file from TMP global into file #95.4
;
; Process entries in file #95.4 and apply to target files.
I '$D(^LAHM(95.4,"AF","SCT")) D Q
. K DIR,DIRUT,DIROUT,DTOUT,DUOUT
. S DIR(0)="E",DIR("A",1)="No SNOMED CT codes loaded in LAB MAPPING file",DIR("A")="Press any key to continue"
. D ^DIR
;
K DIR,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)="SO^0:Quit - no action;1:Process SNOMED CT mappings directly;2:Task processing SNOMED CT mappings"
S DIR("A")="Processing Action",DIR("B")="0"
D ^DIR
I Y<1 Q
;
; Check that mail group has members
S LRMAILGROUP="LAB MAPPING"
I '$$GOTLOCAL^XMXAPIG(LRMAILGROUP) D Q
. N XQAID,XQAMSG,XQAROU,XQADATA,XQA
. S LRMAILGROUP="LMI"
. S XQAMSG="Lab "_LRTYPE(0)_" mapping process: No local members in mail group LAB MAPPING"
. S XQA("G."_LRMAILGROUP)="",XQAID="LRSRVR-"_$S(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_$H
. D SETUP^XQALERT
. K DIR,DIRUT,DIROUT,DTOUT,DUOUT
. S DIR(0)="E"
. S DIR("A",1)="No local active members in mail group LAB MAPPING."
. S DIR("A",2)="Loading will be aborted until mail group corrected."
. S DIR("A")="Press any key to continue"
. D ^DIR
;
; Task loading of SCT mapping on lab files
I Y=2 D Q
. N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
. S ZTRTN="TASKSCT^LRSRVR8",ZTDESC="Tasked Loading of SNOMED CT codes mappings on Lab files"
. S ZTSAVE("LRTYPE*")="",ZTSAVE("LRMAILGROUP")=""
. S ZTIO=""
. D ^%ZTLOAD,^%ZISC
. W !,"Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued")
;
; Load SCT mappings interactively.
D TASKSCT
;
Q
;
;
TASKSCT ; Processing applying SCT mappings to local site.
;
; Load SNOMED CT codes into lab files
D TASKMAP^LRSRVR5
;
Q
;
;
SEND ; Send file to LRLABSERVER at specified site.
N DIC,DIR,DIRUT,DTOUT,DUOUT,LRASKDOM,LRCNT,LRFILE,LRI,LRPURGE,LRSITE,LRTYPE,X,Y
;
D TYPE(2)
I LRTYPE<1 Q
;
K DIC,LRSITE
S DIC="^DIC(4,",DIC(0)="EMOQ",DIC("S")="I $D(^LAHM(95.4,""AC"",+Y))"
S X=$$SELECT^LRUTIL(.DIC,.LRSITE,"Institution",10,0,0,0)
I X=0 Q
I X="*" S LRSITE=1
;
K DIR
S DIR(0)="Y",DIR("A")="Purge mapping for site after transmitting",DIR("B")="NO"
D ^DIR
I $D(DIRUT) Q
S LRPURGE=+Y
;
S X=$$GET^XPAR("USR^PKG^SYS","LR MAPPING ASK DOMAIN",1,"Q")
W !
K DIR
S DIR(0)="YO",DIR("B")=$S(X=1:"YES",1:"NO")
S DIR("A",1)="Answer 'YES' if sending to a test system or a different domain"
S DIR("A",2)="and specify that system's mail domain when prompted."
S DIR("A")="Prompt/confirm MailMan Domain for each site"
D ^DIR
I $D(DIRUT) Q
S LRASKDOM=Y
;
K DIR
S DIR(0)="YO",DIR("A")="Ready to send mappings to site(s)",DIR("B")="NO"
D ^DIR
I $D(DIRUT) Q
I Y'=1 Q
;
S LRFILE=95.4
; Do all sites in file
I LRSITE=1 D Q
. S LRSITE=0
. F S LRSITE=$O(^LAHM(LRFILE,"AC",LRSITE)) Q:'LRSITE D
. . S LRSITE(LRSITE)=$$NAME^XUAF4(LRSITE)
. . D BLDMSG
;
; Do selected sites
S LRSITE=0
F S LRSITE=$O(LRSITE(LRSITE)) Q:'LRSITE D BLDMSG
Q
;
;
IMPORT(LRTYPE) ;
; Call with LRTYPE = type of data (1=LOINC, 2=SNOMED, 3=LOINC Database)
;
N LRFILE,LRMAP
;
;ZEXCEPT: ZTQUEUED
;
; Check if file exists.
S LRFILE=95.4
I '$$VFILE^DILFD(LRFILE) D Q
. I '$D(ZTQUEUED) D EN^DDIOL("Lab Mapping Transport File (#"_LRFILE_") does NOT exist","","!") Q
;
S LRTYPE(0)=$S(LRTYPE=1:"LN",LRTYPE=2:"SCT",LRTYPE=3:"LNDB",1:"UNK")
I '$D(ZTQUEUED) W !,"Processing file data and storing in file #",LRFILE D WAIT^DICD
D BUILD
;
K ^TMP($J,"LRMAP")
Q
;
;
BUILD ; Load Records into file
;
N LRCNT,LREND,LRFLD,LRI,LRID,LRLNDBSTART,LRLOINCVERSION,LRNOW,LRQUIT,LRSITE,LRX
;
;ZEXCEPT: LRTYPE,ZTQUEUED
;
;
I '$D(ZTQUEUED) W !
S LRNOW=$$HTFM^XLFDT($H)
; Read and check headers
S (LRCNT,LREND,LRI,LRQUIT)=0
I LRTYPE(0)="LNDB" S LRLNDBSTART=0,LRLOINCVERSION=""
F S LRI=$O(^TMP($J,"LRMAP",LRI)) Q:LRI<1 D Q:LREND
. I '$D(ZTQUEUED),'(LRI#100) W:$X>(IOM-1) ! W "."
. K LRFLD,LRX
. S LRX=^TMP($J,"LRMAP",LRI,0)
. I LRTYPE(0)="LN" D Q
. . I LRI=1 D Q
. . . I LRX'="Station #-File #-IEN|Entry Name" S LREND=1
. . D PARSELN,FILE
. I LRTYPE(0)="SCT" D Q
. . I LRI=1 D Q
. . . D CKSCTHDR Q:LREND
. . . D BUILDMAP
. . D PARSESCT,FILE
. I LRTYPE(0)="LNDB" D Q
. . M LRX=^TMP($J,"LRMAP",LRI,"OVF")
. . I 'LRLNDBSTART D Q
. . . D CKLNDBHR
. . . I LRLNDBSTART D BUILDMLN
. . D PARSELND,FILE
;
I '$D(ZTQUEUED) W !,"Records added: ",LRCNT
;
Q
;
;
PARSELN ; Parse record from TMP global for LOINC mapping
Q
;
;
PARSELND ; Parse record from TMP global for LOINC Databsae loading
;
;ZEXCEPT: LRFLD,LRID,LRMAP,LRMAPPINGFILE,LRLOINCVERSION,LRSITE,LRX
;
N LRI,LRLAST
;
S LRI=0
F S LRI=$O(LRX(LRI)) Q:'LRI S LRX=LRX_LRX(LRI)
S LRX=$TR(LRX,$C(34),"")
S LRID=$P(LRX,$C(9)),LRSITE=""
;
S LRLAST=$L(LRX,$C(9))
I $P(LRX,$C(9),LRLAST)="" S LRLAST=LRLAST-1
F LRI=2:1:LRLAST I $P(LRX,$C(9),LRI)'="" S LRFLD(LRI,0)=LRMAP(LRI),LRFLD(LRI,100,1,0)=$P(LRX,$C(9),LRI)
;
; Also store name of source file used for these entries.
S LRFLD(10000,0)=LRMAP(10000),LRFLD(10000,100,1,0)=$G(LRMAPPINGFILE)
S LRFLD(10001,0)=LRMAP(10001),LRFLD(10001,100,1,0)=$G(LRLOINCVERSION)
;
Q
;
;
PARSESCT ; Parse record from TMP global for SCT mapping
;
N LRI
;
;ZEXCEPT: LRFLD,LRID,LRMAP,LRMAPPINGFILE,LRSITE,LRX
;
S LRID=$P(LRX,"|")
S LRSITE=$$IEN^XUAF4($P(LRID,"-"))
F LRI=2:1:7 I $P(LRX,"|",LRI)'="" S LRFLD(LRI,0)=LRMAP(LRI),LRFLD(LRI,100,1,0)=$P(LRX,"|",LRI)
;
; Also store name of source file used to map these entries.
S LRFLD(10000,0)=LRMAP(10000),LRFLD(10000,100,1,0)=$G(LRMAPPINGFILE)
;
Q
;
;
FILE ; File the data in file
;
N LRFDA,LRI,LRIEN,LRERR,LRY
;
;ZEXCEPT: LRCNT,LRFILE,LRFLD,LRID,LRNOW,LRSITE,LRTYPE,ZTQUEUED
;
; Get and lock file while processing.
F L +^LAHM(95.4,0):999 Q:$T
;
; Build FDA array and merge in data.
S LRFDA(1,LRFILE,"?+1,",.01)=LRID
S LRFDA(1,LRFILE,"?+1,",2)=LRSITE
S LRFDA(1,LRFILE,"?+1,",3)=LRTYPE(0)
S LRFDA(1,LRFILE,"?+1,",4)=0
S LRFDA(1,LRFILE,"?+1,",6)=LRNOW
D UPDATE^DIE("","LRFDA(1)","LRIEN","LRERR")
I $D(LRERR) D Q
. I $D(ZTQUEUED) Q
. K LRY
. S LRY(1)="WARNING: Update failed for ID# "_LRID
. S LRY(2)=$G(LRERR("DIERR","1","TEXT",1))
. D EN^DDIOL(.LRY,"","!!?2")
S LRCNT=LRCNT+1
;
; Store data
S LRI=0
F S LRI=$O(LRFLD(LRI)) Q:'LRI D
. S ^LAHM(LRFILE,LRIEN(1),100,LRI,0)=LRFLD(LRI,0)
. S ^LAHM(LRFILE,LRIEN(1),100,LRI,100,0)="^94.5011^^"
. M ^LAHM(LRFILE,LRIEN(1),100,LRI,100)=LRFLD(LRI,100)
;
; Unlock transport global.
L -^LAHM(95.4,0)
;
Q
;
;
BLDMSG ; Build and send message for a specific site.
;
N LRDOMAIN,LRENDMSG,LRHDL,LRMAXREC,LRMSG,LRXMZ
;
;ZEXCEPT: LRASKDOM,LRCNT,LRFILE,LRI,LRPURGE,LRSITE,LRTYPE,ZTQUEUED
;
;
S LRDOMAIN=$$WHAT^XUAF4(LRSITE,60)
I LRASKDOM D
. N DIC,X,Y
. W !!,"For ",LRSITE(LRSITE)
. I LRDOMAIN'="" S DIC("B")=LRDOMAIN
. S DIC=4.2,DIC(0)="AEMQ",DIC("A")="Send to MailMan DOMAIN: " D ^DIC
. I Y<1 S LRDOMAIN="" Q
. S LRDOMAIN=$P(Y,"^",2)
I LRDOMAIN="" D Q
. I '$D(ZTQUEUED) D EN^DDIOL("No MailMan DOMAIN specified for this facility","","!?2") Q
;
K ^TMP($J,"LRMAP"),^TMP($J,"LRMSG"),^TMP($J,"LRMAP-HDL")
;
; Move entries related to this institution to TMP global.
; Clear file #4 pointer in 2nd piece, resolve institution at target site based on .01 field
I '$D(ZTQUEUED) D
. D WAIT^DICD
. W !,"Processing facility ",LRSITE(LRSITE),!,"Collecting records to build into mail message "
S (LRCNT,LRI,LRMSG)=0
S LRMAXREC=$$GET^XPAR("USR^PKG^SYS","LR MAPPING MESSAGE MAX RECORDS",1,"Q")
I LRMAXREC<1 S LRMAXREC=3000
F S LRI=$O(^LAHM(LRFILE,"AC",LRSITE,LRI)) Q:'LRI D
. I $P(^LAHM(LRFILE,LRI,0),"^",3)'=LRTYPE(0) Q
. S LRCNT=LRCNT+1
. I '(LRCNT#100) W:$X>(IOM-1) ! W "."
. I LRCNT#LRMAXREC=1 S LRMSG=LRMSG+1
. M ^TMP($J,"LRMSG",LRMSG,LRI)=^LAHM(LRFILE,LRI)
. S $P(^TMP($J,"LRMSG",LRMSG,LRI,0),"^",2)=""
;
I '$D(^TMP($J,"LRMSG")) D Q
. I '$D(ZTQUEUED) D EN^DDIOL("NO data to transport","","!?2") Q
;
I '$D(ZTQUEUED) W !,"Building records into mail message"
S (LRI,LRENDMSG)=0
F S LRI=$O(^TMP($J,"LRMSG",LRI)) Q:'LRI D
. K ^TMP($J,"LRMAP")
. M ^TMP($J,"LRMAP")=^TMP($J,"LRMSG",LRI)
. I LRI=LRMSG S LRENDMSG=1
. S X=$$HANDLE^XUSRB4("LR-MAP-"_LRTYPE(0)_"-",0)
. S LRHDL=X,^TMP($J,"LRMAP-HDL",LRI,0)=X
. D BUILDMSG
;
I '$D(ZTQUEUED) D
. W !,"Number of records transported: "_LRCNT
. W !,"MailMan Message ID's: "
. S LRI=""
. F S LRI=$O(LRXMZ(LRI)) Q:LRI="" W ?23,LRI,!
;
K ^TMP($J,"LRMAP"),^TMP($J,"LRMSG")
;
I LRPURGE D PURGE
;
Q
;
;
PURGE ; Purge related entries from file #95.4 for this site.
N DIK,LRCNT,LRI
;
;ZEXCEPT: DA,LRFILE,LRSITE,ZTQUEUED
;
W !,"Purging related entries from file #",LRFILE
I '$D(ZTQUEUED) D WAIT^DICD
;
S (LRCNT,LRI)=0,DIK="^LAHM(LRFILE,"
F S LRI=$O(^LAHM(LRFILE,"AC",LRSITE,LRI)) Q:'LRI D
. S LRCNT=LRCNT+1,DA=LRI D ^DIK
. I '$D(ZTQUEUED),'(LRCNT#100) W:$X>(IOM-1) ! W "."
Q
;
;
GETFILE ; Select the file to process
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,FILE,FILESPEC,LRFSPEC,LRHELP,LRNUM,X,Y
;
;ZEXCEPT: LRFILE,LRMAPPINGFILE,PWD
;
K ^TMP($J),LRFILE
S PWD=$$PWD^%ZISH()
S X=$$GET^XPAR("USR^PKG^SYS","LR MAPPING DEFAULT DIRECTORY",1,"Q")
I X'="" S PWD=X
S LRFILE=""
;
S DIR(0)="FO^1:245",DIR("A")="Host File Directory",DIR("B")=PWD
F D Q:$D(DIRUT)!(PWD'="")
. D ^DIR
. I $D(DIRUT) Q
. S PWD=$$DEFDIR^%ZISH(Y)
. I PWD="" W !,"Invalid directory syntax",!
I $D(DIRUT) Q
D EN^XPAR("USR","LR MAPPING DEFAULT DIRECTORY",1,PWD)
;
S LRFSPEC=$$GET^XPAR("USR^PKG^SYS","LR MAPPING DEFAULT FILESPEC",1,"Q")
I LRFSPEC'="" S FILESPEC(LRFSPEC)="" W !,"Using filespec ",LRFSPEC
S Y=$$LIST^%ZISH(PWD,"FILESPEC","LRFILE")
I $O(LRFILE(""))="" W !,"No "_$S(LRFSPEC="":"",1:LRFSPEC_" ")_"files found in directory ",PWD,! Q
;
S LRNUM=0,FILE=""
F S FILE=$O(LRFILE(FILE)) Q:FILE="" S LRNUM=LRNUM+1,LRNUM(LRNUM)=FILE,LRHELP(LRNUM)=LRNUM_" "_FILE
K DIR
S DIR(0)="NAO^1:"_LRNUM,DIR("A")="Select FILE: ",DIR("B")=$O(LRNUM(0))
S DIR("?")="Select a file by number from the list" M DIR("?")=LRHELP
D ^DIR
I $D(DIRUT) Q
S (LRFILE,LRMAPPINGFILE)=LRNUM(Y)
Q
;
;
LOADFILE ; Load selected file into TMP global.
;
N LRBACKUPDIR
;
;ZEXCEPT: LRFILE,LRMAILGROUPXQA,PWD,XQA,XQAMSG,Y,ZTQUEUED
;
I '$D(ZTQUEUED) D
. W !,"Directory: "_PWD
. W !,"File.....: "_LRFILE
. W !,"Loading file into TMP global"
. D WAIT^DICD
;
S Y=$$FTG^%ZISH(PWD,LRFILE,$NA(^TMP($J,"LRMAP",1,0)),3,"OVF")
I Y<1 D
. I '$D(ZTQUEUED) W !!,*7,"File failed to load into TMP global",!! Q
. S XQAMSG="Lab Mapping: Unable to load "_LRFILE_" into TMP global"
. S XQA(LRMAILGROUPXQA)=""
. S XQA(DUZ)=""
. D SETUP^XQALERT
;
;
; If processed directory specified then move file to that directory
S LRBACKUPDIR=$$GET^XPAR("USR^PKG^SYS","LR MAPPING PROCESSED DIRECTORY",1,"Q")
I LRBACKUPDIR="" Q
S Y=$$MV^%ZISH(PWD,LRFILE,LRBACKUPDIR,LRFILE)
I Y<1 D
. I '$D(ZTQUEUED) W !!,*7,"Failed to move file from directory "_PWD_" to directory "_LRBACKUPDIR,!! Q
. S XQAMSG="Lab Mapping: Unable to move "_LRFILE_" to "_LRBACKUPDIR
. S XQA(LRMAILGROUPXQA)=""
. S XQA(DUZ)=""
. D SETUP^XQALERT
;
Q
;
;
BUILDMAP ; Build map of field names related to field # in record
N I,LRLAST,LRY
;
;ZEXCEPT: LRMAP,LRX
;
K LRMAP
;
; SNOMED CT format 1: Station #-File #-IEN|Entry Name|SNOMED I|STS_FURTHER_ACTION|STS_SCT_ID|STS_TYPE_OF_MATCH|
; SNOMED CT format 2: Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER|
; SNOMED CT format 2: Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|
;
; LOINC format: TBD
;
; Handle if last character a delimiter or part of field name
S LRLAST=$L(LRX,"|")
I $P(LRX,"|",LRLAST)="" S LRLAST=LRLAST-1
F I=1:1:LRLAST S LRY=$S($P(LRX,"|",I)'="":$P(LRX,"|",I),1:"BLANK"),LRMAP(I)=I_":"_LRY
;
S LRMAP(10000)="10000:MAPPING SOURCE FILE"
;
Q
;
;
BUILDMLN ; Build map of field names related to field # in record for LOINC database file
N I,LRLAST,LRY
;
;ZEXCEPT: LRMAP,LRX
;
K LRMAP
;
; LOINC format: TBD
;
; Handle if last character a delimiter or part of field name
S I=0
F S I=$O(LRX(I)) Q:'I S LRX=LRX_LRX(I)
S LRX=$TR(LRX,$C(34),"")
;
S LRLAST=$L(LRX,$C(9))
I $P(LRX,$C(9),LRLAST)="" S LRLAST=LRLAST-1
F I=1:1:LRLAST S LRY=$S($P(LRX,$C(9),I)'="":$P(LRX,$C(9),I),1:"BLANK-"_I),LRMAP(I)=I_":"_LRY
;
S LRMAP(10000)="10000:MAPPING SOURCE FILE"
S LRMAP(10001)="10001:LOINC VERSION"
;
Q
;
;
TYPE(LRFUNC) ; Ask what code set
; Call with function to perform: 1-load mapping file, 2-transport mapping to site
;
N DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y
;
;ZEXCEPT: LRTYPE
;
;
S DIR(0)="SO^1:LOINC;2:SNOMED CT;3:LOINC Database",DIR("A")="Type of mapping to "_$S(LRFUNC=1:"load",LRFUNC=2:"transport",1:"")
D ^DIR
I $D(DIRUT) S LRTYPE=0 Q
S LRTYPE=Y,LRTYPE(0)=$S(Y=1:"LN",Y=2:"SCT",Y=3:"LNDB",1:"")
Q
;
;
BUILDMSG ; Build the MailMan PackMan message
;
N LRI,MSG,XMDUN,XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,X,Y
;
;ZEXCEPT: LRDOMAIN,LRENDMSG,LRHDL,LRTYPE,LRXMZ
;
K ^TMP("XMP",$J)
S ^TMP("XMP",$J,1,0)=LRHDL
;
S XMSUB=$S(LRTYPE=1:"RELMA",LRTYPE=2:"SNOMED",1:"")_" MAPPING",XMY("S.LRLABSERVER@"_LRDOMAIN)="",XMTEXT="^TMP($J,""LRMAP"",;"
I LRENDMSG S XMTEXT=XMTEXT_"^TMP($J,""LRMAP-HDL"",;"
S XMDUN="Lab Server",XMDUZ=".5"
D ENT^XMPG
;
; Inform sender of action status
S MSG=""
I $G(XMZ)>0 D
. S LRXMZ(XMZ)=""
. S MSG(1)="MailMan message #"_XMZ_" queued for transmission to:",MSG(1,"F")="!!"
. S MSG(2)="S.LRLABSERVER@"_LRDOMAIN,MSG(2,"F")="!?3"
E S MSG(1)="MailMan message generation failed with error: ",MSG(1,"F")="!!",MSG(2)=XMMG,MSG(2,"F")="!?3"
D EN^DDIOL(.MSG,"","")
Q
;
;
INIT ; Initialize variables used by process.
;
;ZEXCEPT: LRMAILGROUP,LRMAILGROUPXQA
;
S (LRMAILGROUP,LRMAILGROUPXQA)="G.LAB MAPPING"
; If no local members then use LMI group
I '$$GOTLOCAL^XMXAPIG("LAB MAPPING") S (LRMAILGROUP,LRMAILGROUPXQA)="G.LMI"
;
Q
;
;
CKSCTHDR ; Check the header of the file to determine if it's
; - the right type of file
; - the record format
;
;ZEXCEPT: LREND,LRQUIT,LRRECORDFORMAT,LRX
;
N LRY
;
S (LRQUIT,LREND)=1,LRRECORDFORMAT=0
;
S LRY="STATION #-FILE #-IEN|ENTRY NAME|SNOMED I|STS_FURTHER_ACTION|STS_SCT_ID|STS_TYPE_OF_MATCH|"
I $$UP^XLFSTR(LRX)=LRY S (LRQUIT,LREND)=0,LRRECORDFORMAT=1 Q
;
S LRY="STATION #-FILE #-IEN|ENTRY NAME|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER|"
I $$UP^XLFSTR(LRX)=LRY S (LRQUIT,LREND)=0,LRRECORDFORMAT=2 Q
;
S LRY="STATION #-FILE #-IEN|ENTRY NAME|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|"
I $$UP^XLFSTR(LRX)=LRY S (LRQUIT,LREND)=0,LRRECORDFORMAT=2 Q
;
Q
;
;
CKLNDBHR ; Check the header of the file to determine if it's
; - the right type of file
; - the record format
;
;ZEXCEPT: LREND,LRQUIT,LRLNDBSTART,LRLOINCVERSION,LRX
;
N LRY
;
S LRX=$TR(LRX,$C(34),"")
;
S LRY="LOINC(R) Database Version"
I $E(LRX,1,$L(LRY))=LRY S LRLOINCVERSION=$$TRIM^XLFSTR($E(LRX,$L(LRY)+1,$L(LRX)),"LR"," ") Q
;
S LRY="LOINC_NUM"
I $$UP^XLFSTR($E(LRX,1,$L(LRY)))=LRY S (LRQUIT,LREND)=0,LRLNDBSTART=1
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSRVR8 17483 printed Apr 09, 2024@21:24:34 Page 2
LRSRVR8 ; DALOI/JMC - LAB DATA SERVER - Utilities ;03/22/11 15:23
+1 ;;5.2;LAB SERVICE;**350,495**;Sep 27, 1994;Build 6
+2 ;
+3 ; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*495; Jul 10 2017
+4 ;
+5 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+6 ; used in conjunction with Eclipse M-editor.
+7 ;
LOAD ; Load mapping file into VistA as file server for distribution to other sites.
+1 ;
+2 NEW LRFILE,LRRECORDFORMAT,LRMAILGROUP,LRMAILGROUPXQA,LRMAPPINGFILE,LRTYPE,PWD
+3 KILL ^TMP($JOB)
+4 ;
+5 DO TYPE(1)
+6 IF LRTYPE<1
QUIT
+7 ;
+8 ; Select/get mapping file
+9 DO GETFILE
+10 IF LRFILE=""
QUIT
+11 ;
+12 ; Load file into TMP global
+13 DO LOADFILE
+14 ;
+15 ; Process file from TMP global into file #95.4
+16 IF $DATA(^TMP($JOB,"LRMAP"))
DO IMPORT(LRTYPE)
+17 QUIT
+18 ;
+19 ;
LOADSCT ; Load SCT mapping file into VistA and apply mapping.
+1 ; Called by option LA7S LOAD MAPPING SCT to load and apply mapping directly at the site.
+2 ;
+3 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,LRACTION,LRFILE,LRMAILGROUP,LRMAPPINGFILE,LRRECORDFORMAT,LRTYPE,PWD,X,Y
+4 KILL ^TMP($JOB)
+5 ; START OF CHANGE FOR LR*5.2*495
+6 ;S LRTYPE=2,LRTYPE(0)="SCT",LRACTION=1
+7 SET LRTYPE=2
SET LRTYPE(0)="SCT"
SET LRACTION=0
+8 IF '$DATA(^LAHM(95.4,"AF","SCT"))
Begin DoDot:1
+9 KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+10 SET DIR(0)="E"
SET DIR("A",1)="No SNOMED CT codes loaded in LAB MAPPING file"
SET DIR("A")="Press any key to continue"
+11 DO ^DIR
End DoDot:1
QUIT
+12 ;
+13 ; END OF CHANGE FOR LR*5.2*495 #1
+14 ;
+15 ; Ask if just processing exiting entries and/or load a file.
+16 IF $DATA(^LAHM(95.4,"AF","SCT"))
Begin DoDot:1
+17 KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+18 ; START OF CHANGE FOR LR*5.2*495
+19 ;S DIR(0)="SO^1:Load file;2:Process previous loaded file",DIR("B")="2"
+20 SET DIR(0)="SO^0:Quit - no action;2:Process previous loaded file"
SET DIR("B")="2"
+21 ; END OF CHANGE FOR LR*5.2*495 #2
+22 DO ^DIR
+23 IF Y<1
SET LRACTION=0
QUIT
+24 SET LRACTION=+Y
End DoDot:1
+25 ;
+26 IF LRACTION<1
QUIT
+27 ;
+28 IF LRACTION=1
Begin DoDot:1
+29 ; Select/get mapping file
DO GETFILE
+30 IF LRFILE=""
QUIT
+31 ;
+32 ; Load file into TMP global
DO LOADFILE
+33 IF '$DATA(^TMP($JOB,"LRMAP"))
QUIT
+34 ;
+35 ; Process file from TMP global into file #95.4
DO IMPORT(LRTYPE)
End DoDot:1
+36 ;
+37 ; Process entries in file #95.4 and apply to target files.
+38 IF '$DATA(^LAHM(95.4,"AF","SCT"))
Begin DoDot:1
+39 KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+40 SET DIR(0)="E"
SET DIR("A",1)="No SNOMED CT codes loaded in LAB MAPPING file"
SET DIR("A")="Press any key to continue"
+41 DO ^DIR
End DoDot:1
QUIT
+42 ;
+43 KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+44 SET DIR(0)="SO^0:Quit - no action;1:Process SNOMED CT mappings directly;2:Task processing SNOMED CT mappings"
+45 SET DIR("A")="Processing Action"
SET DIR("B")="0"
+46 DO ^DIR
+47 IF Y<1
QUIT
+48 ;
+49 ; Check that mail group has members
+50 SET LRMAILGROUP="LAB MAPPING"
+51 IF '$$GOTLOCAL^XMXAPIG(LRMAILGROUP)
Begin DoDot:1
+52 NEW XQAID,XQAMSG,XQAROU,XQADATA,XQA
+53 SET LRMAILGROUP="LMI"
+54 SET XQAMSG="Lab "_LRTYPE(0)_" mapping process: No local members in mail group LAB MAPPING"
+55 SET XQA("G."_LRMAILGROUP)=""
SET XQAID="LRSRVR-"_$SELECT(LRTYPE=1:"LOINC",LRTYPE=2:"SNOMED CT",1:"UNKNOWN")_"-"_$HOROLOG
+56 DO SETUP^XQALERT
+57 KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+58 SET DIR(0)="E"
+59 SET DIR("A",1)="No local active members in mail group LAB MAPPING."
+60 SET DIR("A",2)="Loading will be aborted until mail group corrected."
+61 SET DIR("A")="Press any key to continue"
+62 DO ^DIR
End DoDot:1
QUIT
+63 ;
+64 ; Task loading of SCT mapping on lab files
+65 IF Y=2
Begin DoDot:1
+66 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+67 SET ZTRTN="TASKSCT^LRSRVR8"
SET ZTDESC="Tasked Loading of SNOMED CT codes mappings on Lab files"
+68 SET ZTSAVE("LRTYPE*")=""
SET ZTSAVE("LRMAILGROUP")=""
+69 SET ZTIO=""
+70 DO ^%ZTLOAD
DO ^%ZISC
+71 WRITE !,"Request "_$SELECT($GET(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued")
End DoDot:1
QUIT
+72 ;
+73 ; Load SCT mappings interactively.
+74 DO TASKSCT
+75 ;
+76 QUIT
+77 ;
+78 ;
TASKSCT ; Processing applying SCT mappings to local site.
+1 ;
+2 ; Load SNOMED CT codes into lab files
+3 DO TASKMAP^LRSRVR5
+4 ;
+5 QUIT
+6 ;
+7 ;
SEND ; Send file to LRLABSERVER at specified site.
+1 NEW DIC,DIR,DIRUT,DTOUT,DUOUT,LRASKDOM,LRCNT,LRFILE,LRI,LRPURGE,LRSITE,LRTYPE,X,Y
+2 ;
+3 DO TYPE(2)
+4 IF LRTYPE<1
QUIT
+5 ;
+6 KILL DIC,LRSITE
+7 SET DIC="^DIC(4,"
SET DIC(0)="EMOQ"
SET DIC("S")="I $D(^LAHM(95.4,""AC"",+Y))"
+8 SET X=$$SELECT^LRUTIL(.DIC,.LRSITE,"Institution",10,0,0,0)
+9 IF X=0
QUIT
+10 IF X="*"
SET LRSITE=1
+11 ;
+12 KILL DIR
+13 SET DIR(0)="Y"
SET DIR("A")="Purge mapping for site after transmitting"
SET DIR("B")="NO"
+14 DO ^DIR
+15 IF $DATA(DIRUT)
QUIT
+16 SET LRPURGE=+Y
+17 ;
+18 SET X=$$GET^XPAR("USR^PKG^SYS","LR MAPPING ASK DOMAIN",1,"Q")
+19 WRITE !
+20 KILL DIR
+21 SET DIR(0)="YO"
SET DIR("B")=$SELECT(X=1:"YES",1:"NO")
+22 SET DIR("A",1)="Answer 'YES' if sending to a test system or a different domain"
+23 SET DIR("A",2)="and specify that system's mail domain when prompted."
+24 SET DIR("A")="Prompt/confirm MailMan Domain for each site"
+25 DO ^DIR
+26 IF $DATA(DIRUT)
QUIT
+27 SET LRASKDOM=Y
+28 ;
+29 KILL DIR
+30 SET DIR(0)="YO"
SET DIR("A")="Ready to send mappings to site(s)"
SET DIR("B")="NO"
+31 DO ^DIR
+32 IF $DATA(DIRUT)
QUIT
+33 IF Y'=1
QUIT
+34 ;
+35 SET LRFILE=95.4
+36 ; Do all sites in file
+37 IF LRSITE=1
Begin DoDot:1
+38 SET LRSITE=0
+39 FOR
SET LRSITE=$ORDER(^LAHM(LRFILE,"AC",LRSITE))
if 'LRSITE
QUIT
Begin DoDot:2
+40 SET LRSITE(LRSITE)=$$NAME^XUAF4(LRSITE)
+41 DO BLDMSG
End DoDot:2
End DoDot:1
QUIT
+42 ;
+43 ; Do selected sites
+44 SET LRSITE=0
+45 FOR
SET LRSITE=$ORDER(LRSITE(LRSITE))
if 'LRSITE
QUIT
DO BLDMSG
+46 QUIT
+47 ;
+48 ;
IMPORT(LRTYPE) ;
+1 ; Call with LRTYPE = type of data (1=LOINC, 2=SNOMED, 3=LOINC Database)
+2 ;
+3 NEW LRFILE,LRMAP
+4 ;
+5 ;ZEXCEPT: ZTQUEUED
+6 ;
+7 ; Check if file exists.
+8 SET LRFILE=95.4
+9 IF '$$VFILE^DILFD(LRFILE)
Begin DoDot:1
+10 IF '$DATA(ZTQUEUED)
DO EN^DDIOL("Lab Mapping Transport File (#"_LRFILE_") does NOT exist","","!")
QUIT
End DoDot:1
QUIT
+11 ;
+12 SET LRTYPE(0)=$SELECT(LRTYPE=1:"LN",LRTYPE=2:"SCT",LRTYPE=3:"LNDB",1:"UNK")
+13 IF '$DATA(ZTQUEUED)
WRITE !,"Processing file data and storing in file #",LRFILE
DO WAIT^DICD
+14 DO BUILD
+15 ;
+16 KILL ^TMP($JOB,"LRMAP")
+17 QUIT
+18 ;
+19 ;
BUILD ; Load Records into file
+1 ;
+2 NEW LRCNT,LREND,LRFLD,LRI,LRID,LRLNDBSTART,LRLOINCVERSION,LRNOW,LRQUIT,LRSITE,LRX
+3 ;
+4 ;ZEXCEPT: LRTYPE,ZTQUEUED
+5 ;
+6 ;
+7 IF '$DATA(ZTQUEUED)
WRITE !
+8 SET LRNOW=$$HTFM^XLFDT($HOROLOG)
+9 ; Read and check headers
+10 SET (LRCNT,LREND,LRI,LRQUIT)=0
+11 IF LRTYPE(0)="LNDB"
SET LRLNDBSTART=0
SET LRLOINCVERSION=""
+12 FOR
SET LRI=$ORDER(^TMP($JOB,"LRMAP",LRI))
if LRI<1
QUIT
Begin DoDot:1
+13 IF '$DATA(ZTQUEUED)
IF '(LRI#100)
if $X>(IOM-1)
WRITE !
WRITE "."
+14 KILL LRFLD,LRX
+15 SET LRX=^TMP($JOB,"LRMAP",LRI,0)
+16 IF LRTYPE(0)="LN"
Begin DoDot:2
+17 IF LRI=1
Begin DoDot:3
+18 IF LRX'="Station #-File #-IEN|Entry Name"
SET LREND=1
End DoDot:3
QUIT
+19 DO PARSELN
DO FILE
End DoDot:2
QUIT
+20 IF LRTYPE(0)="SCT"
Begin DoDot:2
+21 IF LRI=1
Begin DoDot:3
+22 DO CKSCTHDR
if LREND
QUIT
+23 DO BUILDMAP
End DoDot:3
QUIT
+24 DO PARSESCT
DO FILE
End DoDot:2
QUIT
+25 IF LRTYPE(0)="LNDB"
Begin DoDot:2
+26 MERGE LRX=^TMP($JOB,"LRMAP",LRI,"OVF")
+27 IF 'LRLNDBSTART
Begin DoDot:3
+28 DO CKLNDBHR
+29 IF LRLNDBSTART
DO BUILDMLN
End DoDot:3
QUIT
+30 DO PARSELND
DO FILE
End DoDot:2
QUIT
End DoDot:1
if LREND
QUIT
+31 ;
+32 IF '$DATA(ZTQUEUED)
WRITE !,"Records added: ",LRCNT
+33 ;
+34 QUIT
+35 ;
+36 ;
PARSELN ; Parse record from TMP global for LOINC mapping
+1 QUIT
+2 ;
+3 ;
PARSELND ; Parse record from TMP global for LOINC Databsae loading
+1 ;
+2 ;ZEXCEPT: LRFLD,LRID,LRMAP,LRMAPPINGFILE,LRLOINCVERSION,LRSITE,LRX
+3 ;
+4 NEW LRI,LRLAST
+5 ;
+6 SET LRI=0
+7 FOR
SET LRI=$ORDER(LRX(LRI))
if 'LRI
QUIT
SET LRX=LRX_LRX(LRI)
+8 SET LRX=$TRANSLATE(LRX,$CHAR(34),"")
+9 SET LRID=$PIECE(LRX,$CHAR(9))
SET LRSITE=""
+10 ;
+11 SET LRLAST=$LENGTH(LRX,$CHAR(9))
+12 IF $PIECE(LRX,$CHAR(9),LRLAST)=""
SET LRLAST=LRLAST-1
+13 FOR LRI=2:1:LRLAST
IF $PIECE(LRX,$CHAR(9),LRI)'=""
SET LRFLD(LRI,0)=LRMAP(LRI)
SET LRFLD(LRI,100,1,0)=$PIECE(LRX,$CHAR(9),LRI)
+14 ;
+15 ; Also store name of source file used for these entries.
+16 SET LRFLD(10000,0)=LRMAP(10000)
SET LRFLD(10000,100,1,0)=$GET(LRMAPPINGFILE)
+17 SET LRFLD(10001,0)=LRMAP(10001)
SET LRFLD(10001,100,1,0)=$GET(LRLOINCVERSION)
+18 ;
+19 QUIT
+20 ;
+21 ;
PARSESCT ; Parse record from TMP global for SCT mapping
+1 ;
+2 NEW LRI
+3 ;
+4 ;ZEXCEPT: LRFLD,LRID,LRMAP,LRMAPPINGFILE,LRSITE,LRX
+5 ;
+6 SET LRID=$PIECE(LRX,"|")
+7 SET LRSITE=$$IEN^XUAF4($PIECE(LRID,"-"))
+8 FOR LRI=2:1:7
IF $PIECE(LRX,"|",LRI)'=""
SET LRFLD(LRI,0)=LRMAP(LRI)
SET LRFLD(LRI,100,1,0)=$PIECE(LRX,"|",LRI)
+9 ;
+10 ; Also store name of source file used to map these entries.
+11 SET LRFLD(10000,0)=LRMAP(10000)
SET LRFLD(10000,100,1,0)=$GET(LRMAPPINGFILE)
+12 ;
+13 QUIT
+14 ;
+15 ;
FILE ; File the data in file
+1 ;
+2 NEW LRFDA,LRI,LRIEN,LRERR,LRY
+3 ;
+4 ;ZEXCEPT: LRCNT,LRFILE,LRFLD,LRID,LRNOW,LRSITE,LRTYPE,ZTQUEUED
+5 ;
+6 ; Get and lock file while processing.
+7 FOR
LOCK +^LAHM(95.4,0):999
if $TEST
QUIT
+8 ;
+9 ; Build FDA array and merge in data.
+10 SET LRFDA(1,LRFILE,"?+1,",.01)=LRID
+11 SET LRFDA(1,LRFILE,"?+1,",2)=LRSITE
+12 SET LRFDA(1,LRFILE,"?+1,",3)=LRTYPE(0)
+13 SET LRFDA(1,LRFILE,"?+1,",4)=0
+14 SET LRFDA(1,LRFILE,"?+1,",6)=LRNOW
+15 DO UPDATE^DIE("","LRFDA(1)","LRIEN","LRERR")
+16 IF $DATA(LRERR)
Begin DoDot:1
+17 IF $DATA(ZTQUEUED)
QUIT
+18 KILL LRY
+19 SET LRY(1)="WARNING: Update failed for ID# "_LRID
+20 SET LRY(2)=$GET(LRERR("DIERR","1","TEXT",1))
+21 DO EN^DDIOL(.LRY,"","!!?2")
End DoDot:1
QUIT
+22 SET LRCNT=LRCNT+1
+23 ;
+24 ; Store data
+25 SET LRI=0
+26 FOR
SET LRI=$ORDER(LRFLD(LRI))
if 'LRI
QUIT
Begin DoDot:1
+27 SET ^LAHM(LRFILE,LRIEN(1),100,LRI,0)=LRFLD(LRI,0)
+28 SET ^LAHM(LRFILE,LRIEN(1),100,LRI,100,0)="^94.5011^^"
+29 MERGE ^LAHM(LRFILE,LRIEN(1),100,LRI,100)=LRFLD(LRI,100)
End DoDot:1
+30 ;
+31 ; Unlock transport global.
+32 LOCK -^LAHM(95.4,0)
+33 ;
+34 QUIT
+35 ;
+36 ;
BLDMSG ; Build and send message for a specific site.
+1 ;
+2 NEW LRDOMAIN,LRENDMSG,LRHDL,LRMAXREC,LRMSG,LRXMZ
+3 ;
+4 ;ZEXCEPT: LRASKDOM,LRCNT,LRFILE,LRI,LRPURGE,LRSITE,LRTYPE,ZTQUEUED
+5 ;
+6 ;
+7 SET LRDOMAIN=$$WHAT^XUAF4(LRSITE,60)
+8 IF LRASKDOM
Begin DoDot:1
+9 NEW DIC,X,Y
+10 WRITE !!,"For ",LRSITE(LRSITE)
+11 IF LRDOMAIN'=""
SET DIC("B")=LRDOMAIN
+12 SET DIC=4.2
SET DIC(0)="AEMQ"
SET DIC("A")="Send to MailMan DOMAIN: "
DO ^DIC
+13 IF Y<1
SET LRDOMAIN=""
QUIT
+14 SET LRDOMAIN=$PIECE(Y,"^",2)
End DoDot:1
+15 IF LRDOMAIN=""
Begin DoDot:1
+16 IF '$DATA(ZTQUEUED)
DO EN^DDIOL("No MailMan DOMAIN specified for this facility","","!?2")
QUIT
End DoDot:1
QUIT
+17 ;
+18 KILL ^TMP($JOB,"LRMAP"),^TMP($JOB,"LRMSG"),^TMP($JOB,"LRMAP-HDL")
+19 ;
+20 ; Move entries related to this institution to TMP global.
+21 ; Clear file #4 pointer in 2nd piece, resolve institution at target site based on .01 field
+22 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+23 DO WAIT^DICD
+24 WRITE !,"Processing facility ",LRSITE(LRSITE),!,"Collecting records to build into mail message "
End DoDot:1
+25 SET (LRCNT,LRI,LRMSG)=0
+26 SET LRMAXREC=$$GET^XPAR("USR^PKG^SYS","LR MAPPING MESSAGE MAX RECORDS",1,"Q")
+27 IF LRMAXREC<1
SET LRMAXREC=3000
+28 FOR
SET LRI=$ORDER(^LAHM(LRFILE,"AC",LRSITE,LRI))
if 'LRI
QUIT
Begin DoDot:1
+29 IF $PIECE(^LAHM(LRFILE,LRI,0),"^",3)'=LRTYPE(0)
QUIT
+30 SET LRCNT=LRCNT+1
+31 IF '(LRCNT#100)
if $X>(IOM-1)
WRITE !
WRITE "."
+32 IF LRCNT#LRMAXREC=1
SET LRMSG=LRMSG+1
+33 MERGE ^TMP($JOB,"LRMSG",LRMSG,LRI)=^LAHM(LRFILE,LRI)
+34 SET $PIECE(^TMP($JOB,"LRMSG",LRMSG,LRI,0),"^",2)=""
End DoDot:1
+35 ;
+36 IF '$DATA(^TMP($JOB,"LRMSG"))
Begin DoDot:1
+37 IF '$DATA(ZTQUEUED)
DO EN^DDIOL("NO data to transport","","!?2")
QUIT
End DoDot:1
QUIT
+38 ;
+39 IF '$DATA(ZTQUEUED)
WRITE !,"Building records into mail message"
+40 SET (LRI,LRENDMSG)=0
+41 FOR
SET LRI=$ORDER(^TMP($JOB,"LRMSG",LRI))
if 'LRI
QUIT
Begin DoDot:1
+42 KILL ^TMP($JOB,"LRMAP")
+43 MERGE ^TMP($JOB,"LRMAP")=^TMP($JOB,"LRMSG",LRI)
+44 IF LRI=LRMSG
SET LRENDMSG=1
+45 SET X=$$HANDLE^XUSRB4("LR-MAP-"_LRTYPE(0)_"-",0)
+46 SET LRHDL=X
SET ^TMP($JOB,"LRMAP-HDL",LRI,0)=X
+47 DO BUILDMSG
End DoDot:1
+48 ;
+49 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+50 WRITE !,"Number of records transported: "_LRCNT
+51 WRITE !,"MailMan Message ID's: "
+52 SET LRI=""
+53 FOR
SET LRI=$ORDER(LRXMZ(LRI))
if LRI=""
QUIT
WRITE ?23,LRI,!
End DoDot:1
+54 ;
+55 KILL ^TMP($JOB,"LRMAP"),^TMP($JOB,"LRMSG")
+56 ;
+57 IF LRPURGE
DO PURGE
+58 ;
+59 QUIT
+60 ;
+61 ;
PURGE ; Purge related entries from file #95.4 for this site.
+1 NEW DIK,LRCNT,LRI
+2 ;
+3 ;ZEXCEPT: DA,LRFILE,LRSITE,ZTQUEUED
+4 ;
+5 WRITE !,"Purging related entries from file #",LRFILE
+6 IF '$DATA(ZTQUEUED)
DO WAIT^DICD
+7 ;
+8 SET (LRCNT,LRI)=0
SET DIK="^LAHM(LRFILE,"
+9 FOR
SET LRI=$ORDER(^LAHM(LRFILE,"AC",LRSITE,LRI))
if 'LRI
QUIT
Begin DoDot:1
+10 SET LRCNT=LRCNT+1
SET DA=LRI
DO ^DIK
+11 IF '$DATA(ZTQUEUED)
IF '(LRCNT#100)
if $X>(IOM-1)
WRITE !
WRITE "."
End DoDot:1
+12 QUIT
+13 ;
+14 ;
GETFILE ; Select the file to process
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,FILE,FILESPEC,LRFSPEC,LRHELP,LRNUM,X,Y
+2 ;
+3 ;ZEXCEPT: LRFILE,LRMAPPINGFILE,PWD
+4 ;
+5 KILL ^TMP($JOB),LRFILE
+6 SET PWD=$$PWD^%ZISH()
+7 SET X=$$GET^XPAR("USR^PKG^SYS","LR MAPPING DEFAULT DIRECTORY",1,"Q")
+8 IF X'=""
SET PWD=X
+9 SET LRFILE=""
+10 ;
+11 SET DIR(0)="FO^1:245"
SET DIR("A")="Host File Directory"
SET DIR("B")=PWD
+12 FOR
Begin DoDot:1
+13 DO ^DIR
+14 IF $DATA(DIRUT)
QUIT
+15 SET PWD=$$DEFDIR^%ZISH(Y)
+16 IF PWD=""
WRITE !,"Invalid directory syntax",!
End DoDot:1
if $DATA(DIRUT)!(PWD'="")
QUIT
+17 IF $DATA(DIRUT)
QUIT
+18 DO EN^XPAR("USR","LR MAPPING DEFAULT DIRECTORY",1,PWD)
+19 ;
+20 SET LRFSPEC=$$GET^XPAR("USR^PKG^SYS","LR MAPPING DEFAULT FILESPEC",1,"Q")
+21 IF LRFSPEC'=""
SET FILESPEC(LRFSPEC)=""
WRITE !,"Using filespec ",LRFSPEC
+22 SET Y=$$LIST^%ZISH(PWD,"FILESPEC","LRFILE")
+23 IF $ORDER(LRFILE(""))=""
WRITE !,"No "_$SELECT(LRFSPEC="":"",1:LRFSPEC_" ")_"files found in directory ",PWD,!
QUIT
+24 ;
+25 SET LRNUM=0
SET FILE=""
+26 FOR
SET FILE=$ORDER(LRFILE(FILE))
if FILE=""
QUIT
SET LRNUM=LRNUM+1
SET LRNUM(LRNUM)=FILE
SET LRHELP(LRNUM)=LRNUM_" "_FILE
+27 KILL DIR
+28 SET DIR(0)="NAO^1:"_LRNUM
SET DIR("A")="Select FILE: "
SET DIR("B")=$ORDER(LRNUM(0))
+29 SET DIR("?")="Select a file by number from the list"
MERGE DIR("?")=LRHELP
+30 DO ^DIR
+31 IF $DATA(DIRUT)
QUIT
+32 SET (LRFILE,LRMAPPINGFILE)=LRNUM(Y)
+33 QUIT
+34 ;
+35 ;
LOADFILE ; Load selected file into TMP global.
+1 ;
+2 NEW LRBACKUPDIR
+3 ;
+4 ;ZEXCEPT: LRFILE,LRMAILGROUPXQA,PWD,XQA,XQAMSG,Y,ZTQUEUED
+5 ;
+6 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+7 WRITE !,"Directory: "_PWD
+8 WRITE !,"File.....: "_LRFILE
+9 WRITE !,"Loading file into TMP global"
+10 DO WAIT^DICD
End DoDot:1
+11 ;
+12 SET Y=$$FTG^%ZISH(PWD,LRFILE,$NAME(^TMP($JOB,"LRMAP",1,0)),3,"OVF")
+13 IF Y<1
Begin DoDot:1
+14 IF '$DATA(ZTQUEUED)
WRITE !!,*7,"File failed to load into TMP global",!!
QUIT
+15 SET XQAMSG="Lab Mapping: Unable to load "_LRFILE_" into TMP global"
+16 SET XQA(LRMAILGROUPXQA)=""
+17 SET XQA(DUZ)=""
+18 DO SETUP^XQALERT
End DoDot:1
+19 ;
+20 ;
+21 ; If processed directory specified then move file to that directory
+22 SET LRBACKUPDIR=$$GET^XPAR("USR^PKG^SYS","LR MAPPING PROCESSED DIRECTORY",1,"Q")
+23 IF LRBACKUPDIR=""
QUIT
+24 SET Y=$$MV^%ZISH(PWD,LRFILE,LRBACKUPDIR,LRFILE)
+25 IF Y<1
Begin DoDot:1
+26 IF '$DATA(ZTQUEUED)
WRITE !!,*7,"Failed to move file from directory "_PWD_" to directory "_LRBACKUPDIR,!!
QUIT
+27 SET XQAMSG="Lab Mapping: Unable to move "_LRFILE_" to "_LRBACKUPDIR
+28 SET XQA(LRMAILGROUPXQA)=""
+29 SET XQA(DUZ)=""
+30 DO SETUP^XQALERT
End DoDot:1
+31 ;
+32 QUIT
+33 ;
+34 ;
BUILDMAP ; Build map of field names related to field # in record
+1 NEW I,LRLAST,LRY
+2 ;
+3 ;ZEXCEPT: LRMAP,LRX
+4 ;
+5 KILL LRMAP
+6 ;
+7 ; SNOMED CT format 1: Station #-File #-IEN|Entry Name|SNOMED I|STS_FURTHER_ACTION|STS_SCT_ID|STS_TYPE_OF_MATCH|
+8 ; SNOMED CT format 2: Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER|
+9 ; SNOMED CT format 2: Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|
+10 ;
+11 ; LOINC format: TBD
+12 ;
+13 ; Handle if last character a delimiter or part of field name
+14 SET LRLAST=$LENGTH(LRX,"|")
+15 IF $PIECE(LRX,"|",LRLAST)=""
SET LRLAST=LRLAST-1
+16 FOR I=1:1:LRLAST
SET LRY=$SELECT($PIECE(LRX,"|",I)'="":$PIECE(LRX,"|",I),1:"BLANK")
SET LRMAP(I)=I_":"_LRY
+17 ;
+18 SET LRMAP(10000)="10000:MAPPING SOURCE FILE"
+19 ;
+20 QUIT
+21 ;
+22 ;
BUILDMLN ; Build map of field names related to field # in record for LOINC database file
+1 NEW I,LRLAST,LRY
+2 ;
+3 ;ZEXCEPT: LRMAP,LRX
+4 ;
+5 KILL LRMAP
+6 ;
+7 ; LOINC format: TBD
+8 ;
+9 ; Handle if last character a delimiter or part of field name
+10 SET I=0
+11 FOR
SET I=$ORDER(LRX(I))
if 'I
QUIT
SET LRX=LRX_LRX(I)
+12 SET LRX=$TRANSLATE(LRX,$CHAR(34),"")
+13 ;
+14 SET LRLAST=$LENGTH(LRX,$CHAR(9))
+15 IF $PIECE(LRX,$CHAR(9),LRLAST)=""
SET LRLAST=LRLAST-1
+16 FOR I=1:1:LRLAST
SET LRY=$SELECT($PIECE(LRX,$CHAR(9),I)'="":$PIECE(LRX,$CHAR(9),I),1:"BLANK-"_I)
SET LRMAP(I)=I_":"_LRY
+17 ;
+18 SET LRMAP(10000)="10000:MAPPING SOURCE FILE"
+19 SET LRMAP(10001)="10001:LOINC VERSION"
+20 ;
+21 QUIT
+22 ;
+23 ;
TYPE(LRFUNC) ; Ask what code set
+1 ; Call with function to perform: 1-load mapping file, 2-transport mapping to site
+2 ;
+3 NEW DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y
+4 ;
+5 ;ZEXCEPT: LRTYPE
+6 ;
+7 ;
+8 SET DIR(0)="SO^1:LOINC;2:SNOMED CT;3:LOINC Database"
SET DIR("A")="Type of mapping to "_$SELECT(LRFUNC=1:"load",LRFUNC=2:"transport",1:"")
+9 DO ^DIR
+10 IF $DATA(DIRUT)
SET LRTYPE=0
QUIT
+11 SET LRTYPE=Y
SET LRTYPE(0)=$SELECT(Y=1:"LN",Y=2:"SCT",Y=3:"LNDB",1:"")
+12 QUIT
+13 ;
+14 ;
BUILDMSG ; Build the MailMan PackMan message
+1 ;
+2 NEW LRI,MSG,XMDUN,XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,X,Y
+3 ;
+4 ;ZEXCEPT: LRDOMAIN,LRENDMSG,LRHDL,LRTYPE,LRXMZ
+5 ;
+6 KILL ^TMP("XMP",$JOB)
+7 SET ^TMP("XMP",$JOB,1,0)=LRHDL
+8 ;
+9 SET XMSUB=$SELECT(LRTYPE=1:"RELMA",LRTYPE=2:"SNOMED",1:"")_" MAPPING"
SET XMY("S.LRLABSERVER@"_LRDOMAIN)=""
SET XMTEXT="^TMP($J,""LRMAP"",;"
+10 IF LRENDMSG
SET XMTEXT=XMTEXT_"^TMP($J,""LRMAP-HDL"",;"
+11 SET XMDUN="Lab Server"
SET XMDUZ=".5"
+12 DO ENT^XMPG
+13 ;
+14 ; Inform sender of action status
+15 SET MSG=""
+16 IF $GET(XMZ)>0
Begin DoDot:1
+17 SET LRXMZ(XMZ)=""
+18 SET MSG(1)="MailMan message #"_XMZ_" queued for transmission to:"
SET MSG(1,"F")="!!"
+19 SET MSG(2)="S.LRLABSERVER@"_LRDOMAIN
SET MSG(2,"F")="!?3"
End DoDot:1
+20 IF '$TEST
SET MSG(1)="MailMan message generation failed with error: "
SET MSG(1,"F")="!!"
SET MSG(2)=XMMG
SET MSG(2,"F")="!?3"
+21 DO EN^DDIOL(.MSG,"","")
+22 QUIT
+23 ;
+24 ;
INIT ; Initialize variables used by process.
+1 ;
+2 ;ZEXCEPT: LRMAILGROUP,LRMAILGROUPXQA
+3 ;
+4 SET (LRMAILGROUP,LRMAILGROUPXQA)="G.LAB MAPPING"
+5 ; If no local members then use LMI group
+6 IF '$$GOTLOCAL^XMXAPIG("LAB MAPPING")
SET (LRMAILGROUP,LRMAILGROUPXQA)="G.LMI"
+7 ;
+8 QUIT
+9 ;
+10 ;
CKSCTHDR ; Check the header of the file to determine if it's
+1 ; - the right type of file
+2 ; - the record format
+3 ;
+4 ;ZEXCEPT: LREND,LRQUIT,LRRECORDFORMAT,LRX
+5 ;
+6 NEW LRY
+7 ;
+8 SET (LRQUIT,LREND)=1
SET LRRECORDFORMAT=0
+9 ;
+10 SET LRY="STATION #-FILE #-IEN|ENTRY NAME|SNOMED I|STS_FURTHER_ACTION|STS_SCT_ID|STS_TYPE_OF_MATCH|"
+11 IF $$UP^XLFSTR(LRX)=LRY
SET (LRQUIT,LREND)=0
SET LRRECORDFORMAT=1
QUIT
+12 ;
+13 SET LRY="STATION #-FILE #-IEN|ENTRY NAME|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER|"
+14 IF $$UP^XLFSTR(LRX)=LRY
SET (LRQUIT,LREND)=0
SET LRRECORDFORMAT=2
QUIT
+15 ;
+16 SET LRY="STATION #-FILE #-IEN|ENTRY NAME|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|"
+17 IF $$UP^XLFSTR(LRX)=LRY
SET (LRQUIT,LREND)=0
SET LRRECORDFORMAT=2
QUIT
+18 ;
+19 QUIT
+20 ;
+21 ;
CKLNDBHR ; Check the header of the file to determine if it's
+1 ; - the right type of file
+2 ; - the record format
+3 ;
+4 ;ZEXCEPT: LREND,LRQUIT,LRLNDBSTART,LRLOINCVERSION,LRX
+5 ;
+6 NEW LRY
+7 ;
+8 SET LRX=$TRANSLATE(LRX,$CHAR(34),"")
+9 ;
+10 SET LRY="LOINC(R) Database Version"
+11 IF $EXTRACT(LRX,1,$LENGTH(LRY))=LRY
SET LRLOINCVERSION=$$TRIM^XLFSTR($EXTRACT(LRX,$LENGTH(LRY)+1,$LENGTH(LRX)),"LR"," ")
QUIT
+12 ;
+13 SET LRY="LOINC_NUM"
+14 IF $$UP^XLFSTR($EXTRACT(LRX,1,$LENGTH(LRY)))=LRY
SET (LRQUIT,LREND)=0
SET LRLNDBSTART=1
+15 ;
+16 QUIT
