LRVRMI4A ;DALOI/STAFF - LAH/TMP TO FILE 63 ;02/22/17 08:09
;;5.2;LAB SERVICE;**350,427,474,480**;Sep 27, 1994;Build 7
;
; Reference to global ^DD(filenumber,"GL") supported by ICR 999
; Extracts the information in the ^TMP("LRMI",$J) global and stores it into the Lab Data micro subfile.
;
Q
;
N3 ;Process Organism
;
N DIERR,IEN,LRFDA,LRIEN,LRIENS,LRMSG
;
;ZEXCEPT: LRDFN,LRDUZ,LRIDT,LRINTYPE,LRNOW,LRRPTAPP
;
S IEN=0
F S IEN=$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN)) Q:IEN<1 D N3A
;
K LRFDA,LRIENS,LRMSG,DIERR
S LRIEN=LRIDT_","_LRDFN_","
I LRINTYPE=10 S LRFDA(3,63.05,LRIEN,11)=LRNOW
S LRFDA(3,63.05,LRIEN,11.55)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
D FILE^DIE("","LRFDA(3)","LRMSG")
S LRRPTAPP=1
Q
;
;
N3A ; Process each organism
;
N DATA,DIERR,DNFLDS,FLD,I,IEN2,ISOID
N LRCSR,LRCMT,LRDATA,LRFDA,LRI,LRIEN,LRIENS,LRMSG,LRN3,LRX,R633,STAT
;
; ZEXCEPT: IEN,LRDFN,LRIDT,LRINTYPE,LRLL,LRPROF,LRSTATUS
;
S LRN3=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,0))
Q:LRN3=""
S ISOID=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,.1))
Q:ISOID=""
;
; Delete ISOID entry if it exists on LEDI (LRINTYPE=10) interfaces
; On UI interfaces update organism for this isolate id.
S R633=$O(^LR(LRDFN,"MI",LRIDT,3,"C",ISOID,0))
I R633 D
. K LRFDA,LRMSG,LRIENS,DIERR
. S LRIEN=R633_","_LRIDT_","_LRDFN_","
. I LRINTYPE=10 D
. . S LRFDA(3,63.3,LRIEN,.01)="@"
. . S R633=""
. E D
. . S LRFDA(3,63.3,LRIEN,.01)=$P(LRN3,U) ; organism
. . I $P(LRN3,U,2)'="" S LRFDA(3,63.3,LRIEN,1)=$P(LRN3,U,2) ; qty
. D FILE^DIE("","LRFDA(3)","LRMSG")
;
; On LEDI (LRINTYPE=10) interfaces existing ISOID was deleted above so always add record
I 'R633 D
. K LRFDA,LRMSG,LRIENS,DIERR
. S LRIEN="+1,"_LRIDT_","_LRDFN_","
. S LRFDA(3,63.3,LRIEN,.01)=$P(LRN3,U) ; organism
. S LRFDA(3,63.3,LRIEN,.1)=ISOID
. S LRFDA(3,63.3,LRIEN,1)=$P(LRN3,U,2) ; qty
. D UPDATE^DIE("","LRFDA(3)","LRIENS","LRMSG")
. S R633=$G(LRIENS(1))
;
Q:'R633
;
; Store code system references
S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,0,.01))
F LRI=1:1:3 I $P(LRX,"^",LRI) D
. N LRDATA
. S LRDATA(.01)=LRDFN_",MI,"_LRIDT_",3,"_R633_",0"
. S LRDATA(.02)=$S(LRI<3:2,1:3),LRDATA(.03)=$P(LRX,"^",LRI),LRDATA(.04)=$P("LN^NLT^SCT","^",LRI)
. D SETREF^LRUCSR(LRDFN,LRDATA(.01),.LRDATA,1)
;
; Store performing lab
S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,0,.01,1))
I $P(LRX,"^") D SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_",3,"_R633_",0",$P(LRX,"^"))
;
S STAT=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,0,.01,0))
S STAT=$P(STAT,U,1)
D BLDSTAT(63.05,11.5,STAT,.LRSTATUS)
;
; Process organism comments
K LRFDA,LRIENS,LRMSG,DIERR
M LRCMT=^LR(LRDFN,"MI",LRIDT,3,IEN,1)
S IEN2=0
F S IEN2=$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,1,IEN2)) Q:'IEN2 D
. S DATA=^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,1,IEN2,0),DATA=$S(DATA'="":DATA,1:" ")
. I DATA'=" ",$$DUPCHK^LRVRMI3(LRLL,LRPROF,.LRCMT,DATA) Q
. S LRIEN="+"_IEN2_","_R633_","_LRIDT_","_LRDFN_","
. S LRFDA(3,63.31,LRIEN,.01)=DATA
I $D(LRFDA) D UPDATE^DIE("","LRFDA(3)","","LRMSG")
;
; Add drug susceptibilities
S IEN2=2
K LRFDA,LRIENS,LRMSG,DIERR
F S IEN2=$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,IEN2)) Q:'IEN2 D
. S STAT=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,IEN2,.01,0))
. S STAT=$P(STAT,U,1)
. D BLDSTAT(63.05,11.5,STAT,.LRSTATUS)
. S LRIEN=R633_","_LRIDT_","_LRDFN_","
. S DATA=^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,IEN2)
. S DNFLDS=$$DN2FLDS(IEN2,,3)
. F I=1:1:3 D ;
. . S FLD=$P(DNFLDS,"^",I)
. . Q:'FLD
. . S LRFDA(3,63.3,LRIEN,FLD)=$P(DATA,U,I)
. S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,3,IEN,IEN2,.01))
. F I=1:1:3 I $P(LRX,"^",I) S LRCSR(IEN2_";1",$S(I<3:2,1:3),$P("LN^NLT^SCT","^",I))=$P(LRX,"^",I)
; File susceptibilities
I $D(LRFDA) D FILE^DIE("","LRFDA(3)","LRMSG")
;
; Store code system references
I $D(LRCSR) D CSR(.LRCSR,LRDFN_",MI,"_LRIDT_",3,"_IEN_",")
;
Q
;
;
N6 ; Process Parasite
;
N DIERR,IEN,LRFDA,LRIEN,LRIENS,LRMSG
;
;ZEXCEPT: LRDFN,LRDUZ,LRIDT,LRINTYPE,LRLL,LRNOW,LRPROF,LRRPTAPP,LRSTATUS
;
S IEN=0
F S IEN=$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN)) Q:IEN<1 D N6A
;
S LRIEN=LRIDT_","_LRDFN_","
I LRINTYPE=10 S LRFDA(6,63.05,LRIEN,14)=LRNOW
S LRFDA(6,63.05,LRIEN,15.5)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
D FILE^DIE("","LRFDA(6)","LRMSG")
S LRRPTAPP=1
Q
;
;
N6A ; Process individual parasite result
;
N DIERR,IEN2,ISOID,LRFDA,LRI,LRIEN,LRIENS,LRINTYPE,LRMSG,LRN6,LRX,R6334,STAT
;
;ZEXCEPT: LRDFN,LRIDT,LRSTATUS,IEN
;
S LRN6=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,0))
Q:LRN6=""
S ISOID=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,.1))
Q:ISOID=""
;
; Delete ISOID entry if it exists on LEDI (LRINTYPE=10) interfaces
; On UI interfaces update parasite for this isolate id.
S R6334=$O(^LR(LRDFN,"MI",LRIDT,6,"C",ISOID,0))
I R6334 D
. K LRFDA,LRMSG,LRIENS,DIERR
. S LRIEN=R6334_","_LRIDT_","_LRDFN_","
. I LRINTYPE=10 D
. . S LRFDA(6,63.34,LRIEN,.01)="@"
. . S R6334=""
. E S LRFDA(6,63.34,LRIEN,.01)=LRN6 ; parasite
. D FILE^DIE("","LRFDA(6)","LRMSG")
;
; On LEDI (LRINTYPE=10) interfaces existing ISOID was deleted above so always add record
I 'R6334 D
. K LRFDA,LRMSG,LRIENS,DIERR
. S LRIEN="+1,"_LRIDT_","_LRDFN_","
. S LRFDA(6,63.34,LRIEN,.01)=LRN6 ; parasite
. S LRFDA(6,63.34,LRIEN,.1)=ISOID
. D UPDATE^DIE("","LRFDA(6)","LRIENS","LRMSG")
. S R6334=$G(LRIENS(1))
;
Q:'R6334
;
; Store code system references
S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,0,.01))
F LRI=1:1:3 I $P(LRX,"^",LRI) D
. N LRDATA
. S LRDATA(.01)=LRDFN_",MI,"_LRIDT_",6,"_IEN_",0"
. S LRDATA(.02)=$S(LRI<3:2,1:3),LRDATA(.03)=$P(LRX,"^",LRI),LRDATA(.04)=$P("LN^NLT^SCT","^",LRI)
. D SETREF^LRUCSR(LRDFN,LRDATA(.01),.LRDATA,1)
;
; Store performing lab
S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,0,.01,1))
I $P(LRX,"^") D SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_",6,"_R6334_",0",$P(LRX,"^"))
;
S STAT=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,0,.01,0))
S STAT=$P(STAT,U,1)
D BLDSTAT(63.05,15,STAT,.LRSTATUS)
;
; Stage results
K LRFDA,LRMSG,LRIENS,DIERR
S IEN2=0
F S IEN2=$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2)) Q:'IEN2 D N6B
;
Q
;
;
N6B ; Process Parasite Stage results
;
N DATA,DIERR,IEN3,LRCMT,LRCSR,LRFDA,LRI,LRIEN,LRIENS,LRMSG,LRPL,LRX,R6335,STAT
;
;ZEXCEPT: ISOID,LRDFN,LRIDT,LRINTYPE,LRLL,LRPROF,IEN,IEN2,LRSTATUS,R6334
;
; Delete STAGE entry if it exists on LEDI (LRINTYPE=10) interfaces
; On UI interfaces update STAGE for this isolate id.
S DATA=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,0))
S R6335=$O(^LR(LRDFN,"MI",LRIDT,6,IEN,1,"B",ISOID,0))
I R6335 D
. K LRFDA,LRMSG,LRIENS,DIERR
. S LRIEN=R6335_","_LRIDT_","_LRDFN_","
. I LRINTYPE=10 D
. . S LRFDA(6,63.35,LRIEN,.01)="@"
. . S R6335=""
. E D
. . S LRFDA(6,63.35,LRIEN,.01)=$P(DATA,U,1) ;stage
. . S LRFDA(6,63.35,LRIEN,1)=$P(DATA,U,2) ;qty
. D FILE^DIE("","LRFDA(6)","LRMSG")
;
; On LEDI (LRINTYPE=10) interfaces existing STAGE was deleted above so always add record
I 'R6335 D
. K LRFDA,LRMSG,LRIENS,DIERR
. S LRIEN="+"_IEN2_","_R6334_","_LRIDT_","_LRDFN_","
. S DATA=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,0))
. S LRFDA(6,63.35,LRIEN,.01)=$P(DATA,U,1) ;stage
. S LRFDA(6,63.35,LRIEN,1)=$P(DATA,U,2) ;qty
. D UPDATE^DIE("","LRFDA(6)","LRIENS","LRMSG")
. S R6335=$G(LRIENS(IEN2))
;
Q:'R6335
;
S STAT=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,0,.01,0))
S STAT=$P(STAT,U,1)
;
; Store code system references for stage
S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,.01))
F LRI=1:1:3 I $P(LRX,"^",LRI) D
. N LRDATA
. S LRDATA(.01)=LRDFN_",MI,"_LRIDT_",6,"_R6334_",1,"_R6335_",0;1"
. S LRDATA(.02)=$S(LRI<3:2,1:3),LRDATA(.03)=$P(LRX,"^",LRI),LRDATA(.04)=$P("LN^NLT^SCT","^",LRI)
. D SETREF^LRUCSR(LRDFN,LRDATA(.01),.LRDATA,1)
;
; Store code system references for quantity
S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1))
F LRI=1:1:3 I $P(LRX,"^",LRI) D
. N LRDATA
. S LRDATA(.01)=LRDFN_",MI,"_LRIDT_",6,"_R6334_",1,"_R6335_",0;2"
. S LRDATA(.02)=$S(LRI<3:2,1:3),LRDATA(.03)=$P(LRX,"^",LRI),LRDATA(.04)=$P("LN^NLT^SCT","^",LRI)
. D SETREF^LRUCSR(LRDFN,LRDATA(.01),.LRDATA,1)
;
; Store performing lab
S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",6,IEN,1,IEN2,0,.01,1))
I $P(LRX,"^") D SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_",6,"_R6334_",1,"_R6335_",0",$P(LRX,"^"))
;
D BLDSTAT(63.05,15,STAT,.LRSTATUS)
;
; get stage comments
K LRFDA,LRMSG,LRIENS,DIERR
M LRCMT=^LR(LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1)
S LRX=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1,0))
S STAT=$P(LRX,U,4)
D BLDSTAT(63.05,15,STAT,.LRSTATUS)
S IEN3=0
F S IEN3=$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1,IEN3)) Q:IEN3<1 D
. S DATA=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1,IEN3,0)),DATA=$S(DATA'="":DATA,1:" ")
. I DATA'=" ",$$DUPCHK^LRVRMI3(LRLL,LRPROF,.LRCMT,DATA) Q
. S LRIEN="+"_IEN3_","_R6335_","_R6334_","_LRIDT_","_LRDFN_","
. S LRFDA(6,63.351,LRIEN,.01)=DATA
. I $P(LRX,"^") S LRPL(IEN3)=$P(LRX,"^")
. I $P(LRX,"^",3) S LRCSR(IEN3,2,"LN")=$P(LRX,"^",3)
;
I '$D(LRFDA) Q
;
D UPDATE^DIE("","LRFDA(6)","LRIENS","LRMSG")
;
; Store performing lab
S IEN3=0
F S IEN3=$O(LRPL(IEN3)) Q:'IEN3 I $G(LRIENS(IEN3)) D SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_",6,"_LRIENS(IEN3),LRPL(IEN3))
;
; Store code system references
I $D(LRCSR) D CSR^LRVRMI4(.LRCSR,.LRIENS,LRDFN_",MI,"_LRIDT_",6,")
Q
;
;
DN2FLDS(DN,FN,SUB) ;
; Convert a drug node to a field number
;File ^DD(filenumber,"GL")/999
; Inputs
; DN : Drug Node (ie 2.0003)
; FN : <opt> File Number (ie 63.3)
; SUB : <opt> Subscript (ie 3)
; : Note: either FN or SUB must be supplied
; Output
; The three associated field numbers for the drug node
; ie 15^15.1^15.2
N FLDS,I,X
S DN=$G(DN),FN=$G(FN),SUB=$G(SUB)
S FLDS=""
I FN="" D ;
. I SUB=3 S FN=63.3
. I SUB=6 S FN=63.34
. I SUB=9 S FN=63.37
. I SUB=12 S FN=63.39
. I SUB=17 S FN=63.43
I $D(^DD(FN,"GL",DN)) D ;
. F I=1:1:3 S X=$O(^DD(FN,"GL",DN,I,0)) I X S $P(FLDS,"^",I)=X
Q FLDS
;
;
BLDSTAT(FN,FLD,STAT,DATA) ;
; Builds the DATA array used for setting status(es)
; Inputs
; FN : File Number (ie 63.5)
; FLD : Field Number (ie 19)
; STAT : Status (ie "F")
; DATA <byref> : See Outputs
;
; Outputs
; DATA <byref> : DATA(file#,field#)=status DATA(63.05,19)="P"
;
N CURR
I $G(STAT)="" Q
I STAT'?1(1"P",1"F",1"C") S STAT="P"
S CURR=$G(DATA(FN,FLD))
I CURR="" S DATA(FN,FLD)=STAT Q
I CURR=STAT Q
I CURR="P" Q
I CURR="F" D
. I STAT="P" S DATA(FN,FLD)="P" Q
. I STAT="C" S DATA(FN,FLD)="C" Q
Q
;
;
SETSTAT(DATA) ;
; Goes thru DATA array and files the status(es)
; Inputs
; DATA <byref> : DATA(file#,field#)=status ie DATA(63.05,19)="P"
; Outputs
; DATA <byref> : Sets DATA(0)=overall status (P,F,C)
;
N FLD,FN,LRFDA,LRIEN,LRMSG,NODE,STAT,STAT2
;
;ZEXCEPT: LRDFN,LRIDT
;
S LRIEN=LRIDT_","_LRDFN_",",STAT2=""
S NODE="DATA(0)"
F S NODE=$Q(@NODE) Q:NODE="" D
. S FN=$QS(NODE,1),FLD=$QS(NODE,2)
. I 'FN!('FLD) Q
. S STAT=DATA(FN,FLD)
. ; derive "overall" status
. ; P > C > F
. I STAT2="" S STAT2=STAT
. I STAT="P" S STAT2="P"
. I STAT="C",STAT2'="P" S STAT2="C"
. I STAT="F",STAT2'="C",STAT2'="P" S STAT2="F"
. ;
. ;convert "C" to "F"
. I STAT="C" S STAT="F"
. S LRFDA(1,FN,LRIEN,FLD)=STAT
I $D(LRFDA) D FILE^DIE("","LRFDA(1)","LRMSG")
S DATA(0)=STAT2
Q
;
;
CSR(LRCSR,LRREF) ; Store code system references
; Call with LRCSR = array of ien/codes to store as references (pass by value)
; LRREF = root of reference to build full reference to data
;
N IEN,LRDATA,LRDATAREF,LRDFN,LRROOT,ROLE,TYPE
;
S LRROOT="LRCSR",LRDFN=$P(LRREF,",")
F S LRROOT=$Q(@LRROOT) Q:LRROOT="" D
. S IEN=$QS(LRROOT,1),ROLE=$QS(LRROOT,2),TYPE=$QS(LRROOT,3),LRDATAREF=LRREF_IEN
. S LRDATA(.01)=LRDATAREF,LRDATA(.02)=ROLE,LRDATA(.03)=LRCSR(IEN,ROLE,TYPE),LRDATA(.04)=TYPE
. D SETREF^LRUCSR(LRDFN,LRDATAREF,.LRDATA,1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVRMI4A 12178 printed Oct 16, 2024@18:23:38 Page 2
LRVRMI4A ;DALOI/STAFF - LAH/TMP TO FILE 63 ;02/22/17 08:09
+1 ;;5.2;LAB SERVICE;**350,427,474,480**;Sep 27, 1994;Build 7
+2 ;
+3 ; Reference to global ^DD(filenumber,"GL") supported by ICR 999
+4 ; Extracts the information in the ^TMP("LRMI",$J) global and stores it into the Lab Data micro subfile.
+5 ;
+6 QUIT
+7 ;
N3 ;Process Organism
+1 ;
+2 NEW DIERR,IEN,LRFDA,LRIEN,LRIENS,LRMSG
+3 ;
+4 ;ZEXCEPT: LRDFN,LRDUZ,LRIDT,LRINTYPE,LRNOW,LRRPTAPP
+5 ;
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN))
if IEN<1
QUIT
DO N3A
+8 ;
+9 KILL LRFDA,LRIENS,LRMSG,DIERR
+10 SET LRIEN=LRIDT_","_LRDFN_","
+11 IF LRINTYPE=10
SET LRFDA(3,63.05,LRIEN,11)=LRNOW
+12 SET LRFDA(3,63.05,LRIEN,11.55)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
+13 DO FILE^DIE("","LRFDA(3)","LRMSG")
+14 SET LRRPTAPP=1
+15 QUIT
+16 ;
+17 ;
N3A ; Process each organism
+1 ;
+2 NEW DATA,DIERR,DNFLDS,FLD,I,IEN2,ISOID
+3 NEW LRCSR,LRCMT,LRDATA,LRFDA,LRI,LRIEN,LRIENS,LRMSG,LRN3,LRX,R633,STAT
+4 ;
+5 ; ZEXCEPT: IEN,LRDFN,LRIDT,LRINTYPE,LRLL,LRPROF,LRSTATUS
+6 ;
+7 SET LRN3=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,0))
+8 if LRN3=""
QUIT
+9 SET ISOID=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,.1))
+10 if ISOID=""
QUIT
+11 ;
+12 ; Delete ISOID entry if it exists on LEDI (LRINTYPE=10) interfaces
+13 ; On UI interfaces update organism for this isolate id.
+14 SET R633=$ORDER(^LR(LRDFN,"MI",LRIDT,3,"C",ISOID,0))
+15 IF R633
Begin DoDot:1
+16 KILL LRFDA,LRMSG,LRIENS,DIERR
+17 SET LRIEN=R633_","_LRIDT_","_LRDFN_","
+18 IF LRINTYPE=10
Begin DoDot:2
+19 SET LRFDA(3,63.3,LRIEN,.01)="@"
+20 SET R633=""
End DoDot:2
+21 IF '$TEST
Begin DoDot:2
+22 ; organism
SET LRFDA(3,63.3,LRIEN,.01)=$PIECE(LRN3,U)
+23 ; qty
IF $PIECE(LRN3,U,2)'=""
SET LRFDA(3,63.3,LRIEN,1)=$PIECE(LRN3,U,2)
End DoDot:2
+24 DO FILE^DIE("","LRFDA(3)","LRMSG")
End DoDot:1
+25 ;
+26 ; On LEDI (LRINTYPE=10) interfaces existing ISOID was deleted above so always add record
+27 IF 'R633
Begin DoDot:1
+28 KILL LRFDA,LRMSG,LRIENS,DIERR
+29 SET LRIEN="+1,"_LRIDT_","_LRDFN_","
+30 ; organism
SET LRFDA(3,63.3,LRIEN,.01)=$PIECE(LRN3,U)
+31 SET LRFDA(3,63.3,LRIEN,.1)=ISOID
+32 ; qty
SET LRFDA(3,63.3,LRIEN,1)=$PIECE(LRN3,U,2)
+33 DO UPDATE^DIE("","LRFDA(3)","LRIENS","LRMSG")
+34 SET R633=$GET(LRIENS(1))
End DoDot:1
+35 ;
+36 if 'R633
QUIT
+37 ;
+38 ; Store code system references
+39 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,0,.01))
+40 FOR LRI=1:1:3
IF $PIECE(LRX,"^",LRI)
Begin DoDot:1
+41 NEW LRDATA
+42 SET LRDATA(.01)=LRDFN_",MI,"_LRIDT_",3,"_R633_",0"
+43 SET LRDATA(.02)=$SELECT(LRI<3:2,1:3)
SET LRDATA(.03)=$PIECE(LRX,"^",LRI)
SET LRDATA(.04)=$PIECE("LN^NLT^SCT","^",LRI)
+44 DO SETREF^LRUCSR(LRDFN,LRDATA(.01),.LRDATA,1)
End DoDot:1
+45 ;
+46 ; Store performing lab
+47 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,0,.01,1))
+48 IF $PIECE(LRX,"^")
DO SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_",3,"_R633_",0",$PIECE(LRX,"^"))
+49 ;
+50 SET STAT=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,0,.01,0))
+51 SET STAT=$PIECE(STAT,U,1)
+52 DO BLDSTAT(63.05,11.5,STAT,.LRSTATUS)
+53 ;
+54 ; Process organism comments
+55 KILL LRFDA,LRIENS,LRMSG,DIERR
+56 MERGE LRCMT=^LR(LRDFN,"MI",LRIDT,3,IEN,1)
+57 SET IEN2=0
+58 FOR
SET IEN2=$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,1,IEN2))
if 'IEN2
QUIT
Begin DoDot:1
+59 SET DATA=^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,1,IEN2,0)
SET DATA=$SELECT(DATA'="":DATA,1:" ")
+60 IF DATA'=" "
IF $$DUPCHK^LRVRMI3(LRLL,LRPROF,.LRCMT,DATA)
QUIT
+61 SET LRIEN="+"_IEN2_","_R633_","_LRIDT_","_LRDFN_","
+62 SET LRFDA(3,63.31,LRIEN,.01)=DATA
End DoDot:1
+63 IF $DATA(LRFDA)
DO UPDATE^DIE("","LRFDA(3)","","LRMSG")
+64 ;
+65 ; Add drug susceptibilities
+66 SET IEN2=2
+67 KILL LRFDA,LRIENS,LRMSG,DIERR
+68 FOR
SET IEN2=$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,IEN2))
if 'IEN2
QUIT
Begin DoDot:1
+69 SET STAT=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,IEN2,.01,0))
+70 SET STAT=$PIECE(STAT,U,1)
+71 DO BLDSTAT(63.05,11.5,STAT,.LRSTATUS)
+72 SET LRIEN=R633_","_LRIDT_","_LRDFN_","
+73 SET DATA=^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,IEN2)
+74 SET DNFLDS=$$DN2FLDS(IEN2,,3)
+75 ;
FOR I=1:1:3
Begin DoDot:2
+76 SET FLD=$PIECE(DNFLDS,"^",I)
+77 if 'FLD
QUIT
+78 SET LRFDA(3,63.3,LRIEN,FLD)=$PIECE(DATA,U,I)
End DoDot:2
+79 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,3,IEN,IEN2,.01))
+80 FOR I=1:1:3
IF $PIECE(LRX,"^",I)
SET LRCSR(IEN2_";1",$SELECT(I<3:2,1:3),$PIECE("LN^NLT^SCT","^",I))=$PIECE(LRX,"^",I)
End DoDot:1
+81 ; File susceptibilities
+82 IF $DATA(LRFDA)
DO FILE^DIE("","LRFDA(3)","LRMSG")
+83 ;
+84 ; Store code system references
+85 IF $DATA(LRCSR)
DO CSR(.LRCSR,LRDFN_",MI,"_LRIDT_",3,"_IEN_",")
+86 ;
+87 QUIT
+88 ;
+89 ;
N6 ; Process Parasite
+1 ;
+2 NEW DIERR,IEN,LRFDA,LRIEN,LRIENS,LRMSG
+3 ;
+4 ;ZEXCEPT: LRDFN,LRDUZ,LRIDT,LRINTYPE,LRLL,LRNOW,LRPROF,LRRPTAPP,LRSTATUS
+5 ;
+6 SET IEN=0
+7 FOR
SET IEN=$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN))
if IEN<1
QUIT
DO N6A
+8 ;
+9 SET LRIEN=LRIDT_","_LRDFN_","
+10 IF LRINTYPE=10
SET LRFDA(6,63.05,LRIEN,14)=LRNOW
+11 SET LRFDA(6,63.05,LRIEN,15.5)=$SELECT($GET(LRDUZ):LRDUZ,1:$GET(DUZ))
+12 DO FILE^DIE("","LRFDA(6)","LRMSG")
+13 SET LRRPTAPP=1
+14 QUIT
+15 ;
+16 ;
N6A ; Process individual parasite result
+1 ;
+2 NEW DIERR,IEN2,ISOID,LRFDA,LRI,LRIEN,LRIENS,LRINTYPE,LRMSG,LRN6,LRX,R6334,STAT
+3 ;
+4 ;ZEXCEPT: LRDFN,LRIDT,LRSTATUS,IEN
+5 ;
+6 SET LRN6=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,0))
+7 if LRN6=""
QUIT
+8 SET ISOID=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,.1))
+9 if ISOID=""
QUIT
+10 ;
+11 ; Delete ISOID entry if it exists on LEDI (LRINTYPE=10) interfaces
+12 ; On UI interfaces update parasite for this isolate id.
+13 SET R6334=$ORDER(^LR(LRDFN,"MI",LRIDT,6,"C",ISOID,0))
+14 IF R6334
Begin DoDot:1
+15 KILL LRFDA,LRMSG,LRIENS,DIERR
+16 SET LRIEN=R6334_","_LRIDT_","_LRDFN_","
+17 IF LRINTYPE=10
Begin DoDot:2
+18 SET LRFDA(6,63.34,LRIEN,.01)="@"
+19 SET R6334=""
End DoDot:2
+20 ; parasite
IF '$TEST
SET LRFDA(6,63.34,LRIEN,.01)=LRN6
+21 DO FILE^DIE("","LRFDA(6)","LRMSG")
End DoDot:1
+22 ;
+23 ; On LEDI (LRINTYPE=10) interfaces existing ISOID was deleted above so always add record
+24 IF 'R6334
Begin DoDot:1
+25 KILL LRFDA,LRMSG,LRIENS,DIERR
+26 SET LRIEN="+1,"_LRIDT_","_LRDFN_","
+27 ; parasite
SET LRFDA(6,63.34,LRIEN,.01)=LRN6
+28 SET LRFDA(6,63.34,LRIEN,.1)=ISOID
+29 DO UPDATE^DIE("","LRFDA(6)","LRIENS","LRMSG")
+30 SET R6334=$GET(LRIENS(1))
End DoDot:1
+31 ;
+32 if 'R6334
QUIT
+33 ;
+34 ; Store code system references
+35 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,0,.01))
+36 FOR LRI=1:1:3
IF $PIECE(LRX,"^",LRI)
Begin DoDot:1
+37 NEW LRDATA
+38 SET LRDATA(.01)=LRDFN_",MI,"_LRIDT_",6,"_IEN_",0"
+39 SET LRDATA(.02)=$SELECT(LRI<3:2,1:3)
SET LRDATA(.03)=$PIECE(LRX,"^",LRI)
SET LRDATA(.04)=$PIECE("LN^NLT^SCT","^",LRI)
+40 DO SETREF^LRUCSR(LRDFN,LRDATA(.01),.LRDATA,1)
End DoDot:1
+41 ;
+42 ; Store performing lab
+43 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,0,.01,1))
+44 IF $PIECE(LRX,"^")
DO SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_",6,"_R6334_",0",$PIECE(LRX,"^"))
+45 ;
+46 SET STAT=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,0,.01,0))
+47 SET STAT=$PIECE(STAT,U,1)
+48 DO BLDSTAT(63.05,15,STAT,.LRSTATUS)
+49 ;
+50 ; Stage results
+51 KILL LRFDA,LRMSG,LRIENS,DIERR
+52 SET IEN2=0
+53 FOR
SET IEN2=$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2))
if 'IEN2
QUIT
DO N6B
+54 ;
+55 QUIT
+56 ;
+57 ;
N6B ; Process Parasite Stage results
+1 ;
+2 NEW DATA,DIERR,IEN3,LRCMT,LRCSR,LRFDA,LRI,LRIEN,LRIENS,LRMSG,LRPL,LRX,R6335,STAT
+3 ;
+4 ;ZEXCEPT: ISOID,LRDFN,LRIDT,LRINTYPE,LRLL,LRPROF,IEN,IEN2,LRSTATUS,R6334
+5 ;
+6 ; Delete STAGE entry if it exists on LEDI (LRINTYPE=10) interfaces
+7 ; On UI interfaces update STAGE for this isolate id.
+8 SET DATA=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,0))
+9 SET R6335=$ORDER(^LR(LRDFN,"MI",LRIDT,6,IEN,1,"B",ISOID,0))
+10 IF R6335
Begin DoDot:1
+11 KILL LRFDA,LRMSG,LRIENS,DIERR
+12 SET LRIEN=R6335_","_LRIDT_","_LRDFN_","
+13 IF LRINTYPE=10
Begin DoDot:2
+14 SET LRFDA(6,63.35,LRIEN,.01)="@"
+15 SET R6335=""
End DoDot:2
+16 IF '$TEST
Begin DoDot:2
+17 ;stage
SET LRFDA(6,63.35,LRIEN,.01)=$PIECE(DATA,U,1)
+18 ;qty
SET LRFDA(6,63.35,LRIEN,1)=$PIECE(DATA,U,2)
End DoDot:2
+19 DO FILE^DIE("","LRFDA(6)","LRMSG")
End DoDot:1
+20 ;
+21 ; On LEDI (LRINTYPE=10) interfaces existing STAGE was deleted above so always add record
+22 IF 'R6335
Begin DoDot:1
+23 KILL LRFDA,LRMSG,LRIENS,DIERR
+24 SET LRIEN="+"_IEN2_","_R6334_","_LRIDT_","_LRDFN_","
+25 SET DATA=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,0))
+26 ;stage
SET LRFDA(6,63.35,LRIEN,.01)=$PIECE(DATA,U,1)
+27 ;qty
SET LRFDA(6,63.35,LRIEN,1)=$PIECE(DATA,U,2)
+28 DO UPDATE^DIE("","LRFDA(6)","LRIENS","LRMSG")
+29 SET R6335=$GET(LRIENS(IEN2))
End DoDot:1
+30 ;
+31 if 'R6335
QUIT
+32 ;
+33 SET STAT=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,0,.01,0))
+34 SET STAT=$PIECE(STAT,U,1)
+35 ;
+36 ; Store code system references for stage
+37 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,.01))
+38 FOR LRI=1:1:3
IF $PIECE(LRX,"^",LRI)
Begin DoDot:1
+39 NEW LRDATA
+40 SET LRDATA(.01)=LRDFN_",MI,"_LRIDT_",6,"_R6334_",1,"_R6335_",0;1"
+41 SET LRDATA(.02)=$SELECT(LRI<3:2,1:3)
SET LRDATA(.03)=$PIECE(LRX,"^",LRI)
SET LRDATA(.04)=$PIECE("LN^NLT^SCT","^",LRI)
+42 DO SETREF^LRUCSR(LRDFN,LRDATA(.01),.LRDATA,1)
End DoDot:1
+43 ;
+44 ; Store code system references for quantity
+45 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1))
+46 FOR LRI=1:1:3
IF $PIECE(LRX,"^",LRI)
Begin DoDot:1
+47 NEW LRDATA
+48 SET LRDATA(.01)=LRDFN_",MI,"_LRIDT_",6,"_R6334_",1,"_R6335_",0;2"
+49 SET LRDATA(.02)=$SELECT(LRI<3:2,1:3)
SET LRDATA(.03)=$PIECE(LRX,"^",LRI)
SET LRDATA(.04)=$PIECE("LN^NLT^SCT","^",LRI)
+50 DO SETREF^LRUCSR(LRDFN,LRDATA(.01),.LRDATA,1)
End DoDot:1
+51 ;
+52 ; Store performing lab
+53 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",6,IEN,1,IEN2,0,.01,1))
+54 IF $PIECE(LRX,"^")
DO SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_",6,"_R6334_",1,"_R6335_",0",$PIECE(LRX,"^"))
+55 ;
+56 DO BLDSTAT(63.05,15,STAT,.LRSTATUS)
+57 ;
+58 ; get stage comments
+59 KILL LRFDA,LRMSG,LRIENS,DIERR
+60 MERGE LRCMT=^LR(LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1)
+61 SET LRX=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1,0))
+62 SET STAT=$PIECE(LRX,U,4)
+63 DO BLDSTAT(63.05,15,STAT,.LRSTATUS)
+64 SET IEN3=0
+65 FOR
SET IEN3=$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1,IEN3))
if IEN3<1
QUIT
Begin DoDot:1
+66 SET DATA=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,6,IEN,1,IEN2,1,IEN3,0))
SET DATA=$SELECT(DATA'="":DATA,1:" ")
+67 IF DATA'=" "
IF $$DUPCHK^LRVRMI3(LRLL,LRPROF,.LRCMT,DATA)
QUIT
+68 SET LRIEN="+"_IEN3_","_R6335_","_R6334_","_LRIDT_","_LRDFN_","
+69 SET LRFDA(6,63.351,LRIEN,.01)=DATA
+70 IF $PIECE(LRX,"^")
SET LRPL(IEN3)=$PIECE(LRX,"^")
+71 IF $PIECE(LRX,"^",3)
SET LRCSR(IEN3,2,"LN")=$PIECE(LRX,"^",3)
End DoDot:1
+72 ;
+73 IF '$DATA(LRFDA)
QUIT
+74 ;
+75 DO UPDATE^DIE("","LRFDA(6)","LRIENS","LRMSG")
+76 ;
+77 ; Store performing lab
+78 SET IEN3=0
+79 FOR
SET IEN3=$ORDER(LRPL(IEN3))
if 'IEN3
QUIT
IF $GET(LRIENS(IEN3))
DO SETPL^LRRPLUA(LRDFN_",MI,"_LRIDT_",6,"_LRIENS(IEN3),LRPL(IEN3))
+80 ;
+81 ; Store code system references
+82 IF $DATA(LRCSR)
DO CSR^LRVRMI4(.LRCSR,.LRIENS,LRDFN_",MI,"_LRIDT_",6,")
+83 QUIT
+84 ;
+85 ;
DN2FLDS(DN,FN,SUB) ;
+1 ; Convert a drug node to a field number
+2 ;File ^DD(filenumber,"GL")/999
+3 ; Inputs
+4 ; DN : Drug Node (ie 2.0003)
+5 ; FN : <opt> File Number (ie 63.3)
+6 ; SUB : <opt> Subscript (ie 3)
+7 ; : Note: either FN or SUB must be supplied
+8 ; Output
+9 ; The three associated field numbers for the drug node
+10 ; ie 15^15.1^15.2
+11 NEW FLDS,I,X
+12 SET DN=$GET(DN)
SET FN=$GET(FN)
SET SUB=$GET(SUB)
+13 SET FLDS=""
+14 ;
IF FN=""
Begin DoDot:1
+15 IF SUB=3
SET FN=63.3
+16 IF SUB=6
SET FN=63.34
+17 IF SUB=9
SET FN=63.37
+18 IF SUB=12
SET FN=63.39
+19 IF SUB=17
SET FN=63.43
End DoDot:1
+20 ;
IF $DATA(^DD(FN,"GL",DN))
Begin DoDot:1
+21 FOR I=1:1:3
SET X=$ORDER(^DD(FN,"GL",DN,I,0))
IF X
SET $PIECE(FLDS,"^",I)=X
End DoDot:1
+22 QUIT FLDS
+23 ;
+24 ;
BLDSTAT(FN,FLD,STAT,DATA) ;
+1 ; Builds the DATA array used for setting status(es)
+2 ; Inputs
+3 ; FN : File Number (ie 63.5)
+4 ; FLD : Field Number (ie 19)
+5 ; STAT : Status (ie "F")
+6 ; DATA <byref> : See Outputs
+7 ;
+8 ; Outputs
+9 ; DATA <byref> : DATA(file#,field#)=status DATA(63.05,19)="P"
+10 ;
+11 NEW CURR
+12 IF $GET(STAT)=""
QUIT
+13 IF STAT'?1(1"P",1"F",1"C")
SET STAT="P"
+14 SET CURR=$GET(DATA(FN,FLD))
+15 IF CURR=""
SET DATA(FN,FLD)=STAT
QUIT
+16 IF CURR=STAT
QUIT
+17 IF CURR="P"
QUIT
+18 IF CURR="F"
Begin DoDot:1
+19 IF STAT="P"
SET DATA(FN,FLD)="P"
QUIT
+20 IF STAT="C"
SET DATA(FN,FLD)="C"
QUIT
End DoDot:1
+21 QUIT
+22 ;
+23 ;
SETSTAT(DATA) ;
+1 ; Goes thru DATA array and files the status(es)
+2 ; Inputs
+3 ; DATA <byref> : DATA(file#,field#)=status ie DATA(63.05,19)="P"
+4 ; Outputs
+5 ; DATA <byref> : Sets DATA(0)=overall status (P,F,C)
+6 ;
+7 NEW FLD,FN,LRFDA,LRIEN,LRMSG,NODE,STAT,STAT2
+8 ;
+9 ;ZEXCEPT: LRDFN,LRIDT
+10 ;
+11 SET LRIEN=LRIDT_","_LRDFN_","
SET STAT2=""
+12 SET NODE="DATA(0)"
+13 FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
Begin DoDot:1
+14 SET FN=$QSUBSCRIPT(NODE,1)
SET FLD=$QSUBSCRIPT(NODE,2)
+15 IF 'FN!('FLD)
QUIT
+16 SET STAT=DATA(FN,FLD)
+17 ; derive "overall" status
+18 ; P > C > F
+19 IF STAT2=""
SET STAT2=STAT
+20 IF STAT="P"
SET STAT2="P"
+21 IF STAT="C"
IF STAT2'="P"
SET STAT2="C"
+22 IF STAT="F"
IF STAT2'="C"
IF STAT2'="P"
SET STAT2="F"
+23 ;
+24 ;convert "C" to "F"
+25 IF STAT="C"
SET STAT="F"
+26 SET LRFDA(1,FN,LRIEN,FLD)=STAT
End DoDot:1
+27 IF $DATA(LRFDA)
DO FILE^DIE("","LRFDA(1)","LRMSG")
+28 SET DATA(0)=STAT2
+29 QUIT
+30 ;
+31 ;
CSR(LRCSR,LRREF) ; Store code system references
+1 ; Call with LRCSR = array of ien/codes to store as references (pass by value)
+2 ; LRREF = root of reference to build full reference to data
+3 ;
+4 NEW IEN,LRDATA,LRDATAREF,LRDFN,LRROOT,ROLE,TYPE
+5 ;
+6 SET LRROOT="LRCSR"
SET LRDFN=$PIECE(LRREF,",")
+7 FOR
SET LRROOT=$QUERY(@LRROOT)
if LRROOT=""
QUIT
Begin DoDot:1
+8 SET IEN=$QSUBSCRIPT(LRROOT,1)
SET ROLE=$QSUBSCRIPT(LRROOT,2)
SET TYPE=$QSUBSCRIPT(LRROOT,3)
SET LRDATAREF=LRREF_IEN
+9 SET LRDATA(.01)=LRDATAREF
SET LRDATA(.02)=ROLE
SET LRDATA(.03)=LRCSR(IEN,ROLE,TYPE)
SET LRDATA(.04)=TYPE
+10 DO SETREF^LRUCSR(LRDFN,LRDATAREF,.LRDATA,1)
End DoDot:1
+11 QUIT
