LRRPLUA ;DALOI/JMC - Lab Report Performing Lab Utility ;10/28/11 16:33
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
Q
;
;
SETPL(LRREF,LR4) ; Set performing lab reference into workbench
; Call with LRREF = performing lab reference
; LR4 = performing lab IEN in file #4
;
S ^TMP("LRPL",$J,1,LRREF)=LR4
S ^TMP("LRPL",$J,2,LR4,LRREF)=""
;
Q
;
;
ROLLUPPL(LRDFN,LRSS,LRIDT) ; Roll up performing labs and store in file #63
; Call with LRDFN = File #63 internal entry number
; LRSS = File #63 subscript
; LRIDT = inverse date/time of entry in file #63
;
N LRPLAB,LRREF,LRX
;
; Merge/consolidate workbench entries for same basic reference.
; Check and merge TMP entries to create list and elimiate unnecessary multiples.
D MERGE
;
; Update existing entry/create new entry
S LRREF=""
F S LRREF=$O(^TMP("LRPL",$J,1,LRREF)) Q:LRREF="" D
. S LRPLAB=$P(^TMP("LRPL",$J,1,LRREF),"^")
. S LRX=$O(^LR(LRDFN,"PL","B",LRREF,0))
. I 'LRX D CNE^LRRPLU(LRDFN,LRREF,LRPLAB) Q
. I $P(^LR(LRDFN,"PL",LRX,0),"^",2)'=LRPLAB D UEE^LRRPLU(LRDFN,LRREF,LRPLAB)
;
K ^TMP("LRPL",$J)
Q
;
;
MERGE ; Check and merge entries where appropriate.
;
N I,LRJ,LRK,LRONELAB,LRREF,LRX,LRY,LRZ
;
S LRONELAB("ON FILE")="" ; Initialize to no lab (null) on file.
S LRONELAB("INCOMING")=0 ; Intialize to no lab on incoming report.
;
; If only one lab listed in incoming report then set flag to that lab.
S LRX=$O(^TMP("LRPL",$J,2,0))
I '$O(^TMP("LRPL",$J,2,LRX)) S LRONELAB("INCOMING")=LRX
;
; Find out if existing report has performing lab and if more then one.
; If more then one then set flag to 0 (zero).
S LRX=0,LRY=""
F S LRX=$O(^LR(LRDFN,"PL","AC",LRSS,LRIDT,LRX)) Q:'LRX D Q:LRY=0
. I LRY,LRY'=$P(^LR(LRDFN,"PL",LRX,0),"^",2) S LRY=0 Q
. I LRY="" S LRY=$P(^LR(LRDFN,"PL",LRX,0),"^",2)
;
S LRONELAB("ON FILE")=LRY
;
; If all "on file" sections and all "incoming" sections have the same performing lab
; then mark the entire report as being performed by that lab.
I LRONELAB("ON FILE")=LRONELAB("INCOMING") D Q
. K ^TMP("LRPL",$J)
. S LRREF=LRDFN_","_LRSS_","_LRIDT_",0"
. S ^TMP("LRPL",$J,1,LRREF)=LRONELAB("INCOMING")
;
; If no "on file" lab and one "incoming" lab
; then mark entire report as being performed by the "incoming" lab.
I LRONELAB("ON FILE")="",LRONELAB("INCOMING") D Q
. K ^TMP("LRPL",$J)
. S LRREF=LRDFN_","_LRSS_","_LRIDT_",0"
. S ^TMP("LRPL",$J,1,LRREF)=LRONELAB("INCOMING")
;
; Walk up tree to find parent reference that may cover this reference at a higher level
S LRREF=""
F S LRREF=$O(^TMP("LRPL",$J,1,LRREF)) Q:LRREF="" D
. S LRPLAB=$P(^TMP("LRPL",$J,1,LRREF),"^")
. I LRSS="CH" D CHCHK Q
. I LRSS?1(1"MI",1"SP",1"CY",1"EM",1"AU") D MIAPCHK
;
Q
;
;
CHCHK ; Find "on file" performing lab for a "CH" test result.
;
S LRZ=LRREF D CHKNODE
Q
;
;
MIAPCHK ; Find performing lab for a MI or AP subscript reference
;
S LRZ=LRREF D CHKNODE Q:LRY
I $P(LRREF,";",2)'="" S LRZ=$P(LRREF,";") D CHKNODE Q:LRY
;
S LRJ=$L(LRZ,",")
F LRK=LRJ:-1:4 D Q:LRY
. S LRZ=$P(LRZ,",",1,LRK) D CHKNODE Q:LRY
. I $P(LRZ,",",LRK)>0 S $P(LRZ,",",LRK)=0 D CHKNODE
;
I LRSS="MI",LRY="",$P(LRX,",",4)=99 F I=1,5,8,11,16 S $P(LRZ,",",4)=I D CHKNODE Q:LRY
;
Q
;
;
CHKNODE ; Check if "on file" node or parent exists and delete "incoming" if it matches "on file" lab
;
N LRI
S LRY="",LRI=$O(^LR(LRDFN,"PL","B",LRZ,0))
I LRI S LRY=$P(^LR(LRDFN,"PL",LRI,0),"^",2)
I LRY,LRY=LRPLAB K ^TMP("LRPL",$J,1,LRREF) Q
;
; Check if "incoming" has a higher parent for the same lab.
I LRREF'=LRZ D
. S LRY=+$G(^TMP("LRPL",$J,1,LRZ))
. I LRY,LRY=LRPLAB K ^TMP("LRPL",$J,1,LRREF)
Q
;
;
TEST ; Entry point to test/debug
;
N LRAA,LRAD,LRAN,LRACC,LRDFN,LRIDT,LRSS
S LRACC=1
F D Q:LRAA<1
. W !
. D EN^LRWU4
. I LRAA<1 Q
. S LRDFN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^"),LRSS=$P(^LRO(68,LRAA,0),"^",2)
. I LRSS'="AU" S LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
. E S LRIDT=""
. I LRSS="BB" W !,"Blood Bank not supported" Q
. D EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
. W !!
;
Q
;
;
TEST2 ; Entry point test printing performing lab for an accession
;
N LRAA,LRAD,LRAN,LRACC,LRDFN,LRIDT,LRPL,LRSS
S LRACC=1
F D Q:LRAA<1
. W !
. D EN^LRWU4
. I LRAA<1 Q
. S LRDFN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^"),LRSS=$P(^LRO(68,LRAA,0),"^",2)
. I LRSS'="AU" S LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
. E S LRIDT=0
. I LRSS="BB" W !,"Blood Bank not supported" Q
. K LRPL
. D RETLST^LRRPL(.LRPL,LRDFN,LRSS,LRIDT,0)
. I '$O(LRPL(0)) K LRPL S LRPL(1)="Performing Lab Sites: None Listed"
. E S LRPL(.5)="Performing Lab Sites:",LRPL(.6)=" "
. W !! D EN^DDIOL(.LRPL)
Q
NOASK ; Set reference to performing lab in file #63 If ASK PERFORMING LAB =NO
; Update if already set otherwise create a new record.
;
N LRDPL,LRFLAG,LRREF,LRPLAB,LRSECT
S LRFLAG=0,LRSECT=0
I LRSS?1(1"MI",1"SP",1"CY",1"EM") S LRFLAG=1
S LRDPL=$$GET^XPAR("USR","LR VER DEFAULT PERFORMING LAB",1,"Q")
I LRDPL<1 S LRDPL=DUZ(2)
S LRPLAB=LRDPL
S LRREF=LRDFN_","_LRSS_","_LRIDT_","_LRSECT
;
W !
; Update existing entry
I $D(^LR(LRDFN,"PL","B",LRREF)) D Q
. D UEE^LRRPLU(LRDFN,LRREF,LRPLAB)
;
; Create new entry
D CNE^LRRPLU(LRDFN,LRREF,LRPLAB)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRPLUA 5402 printed Nov 22, 2024@17:30:14 Page 2
LRRPLUA ;DALOI/JMC - Lab Report Performing Lab Utility ;10/28/11 16:33
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 QUIT
+4 ;
+5 ;
SETPL(LRREF,LR4) ; Set performing lab reference into workbench
+1 ; Call with LRREF = performing lab reference
+2 ; LR4 = performing lab IEN in file #4
+3 ;
+4 SET ^TMP("LRPL",$JOB,1,LRREF)=LR4
+5 SET ^TMP("LRPL",$JOB,2,LR4,LRREF)=""
+6 ;
+7 QUIT
+8 ;
+9 ;
ROLLUPPL(LRDFN,LRSS,LRIDT) ; Roll up performing labs and store in file #63
+1 ; Call with LRDFN = File #63 internal entry number
+2 ; LRSS = File #63 subscript
+3 ; LRIDT = inverse date/time of entry in file #63
+4 ;
+5 NEW LRPLAB,LRREF,LRX
+6 ;
+7 ; Merge/consolidate workbench entries for same basic reference.
+8 ; Check and merge TMP entries to create list and elimiate unnecessary multiples.
+9 DO MERGE
+10 ;
+11 ; Update existing entry/create new entry
+12 SET LRREF=""
+13 FOR
SET LRREF=$ORDER(^TMP("LRPL",$JOB,1,LRREF))
if LRREF=""
QUIT
Begin DoDot:1
+14 SET LRPLAB=$PIECE(^TMP("LRPL",$JOB,1,LRREF),"^")
+15 SET LRX=$ORDER(^LR(LRDFN,"PL","B",LRREF,0))
+16 IF 'LRX
DO CNE^LRRPLU(LRDFN,LRREF,LRPLAB)
QUIT
+17 IF $PIECE(^LR(LRDFN,"PL",LRX,0),"^",2)'=LRPLAB
DO UEE^LRRPLU(LRDFN,LRREF,LRPLAB)
End DoDot:1
+18 ;
+19 KILL ^TMP("LRPL",$JOB)
+20 QUIT
+21 ;
+22 ;
MERGE ; Check and merge entries where appropriate.
+1 ;
+2 NEW I,LRJ,LRK,LRONELAB,LRREF,LRX,LRY,LRZ
+3 ;
+4 ; Initialize to no lab (null) on file.
SET LRONELAB("ON FILE")=""
+5 ; Intialize to no lab on incoming report.
SET LRONELAB("INCOMING")=0
+6 ;
+7 ; If only one lab listed in incoming report then set flag to that lab.
+8 SET LRX=$ORDER(^TMP("LRPL",$JOB,2,0))
+9 IF '$ORDER(^TMP("LRPL",$JOB,2,LRX))
SET LRONELAB("INCOMING")=LRX
+10 ;
+11 ; Find out if existing report has performing lab and if more then one.
+12 ; If more then one then set flag to 0 (zero).
+13 SET LRX=0
SET LRY=""
+14 FOR
SET LRX=$ORDER(^LR(LRDFN,"PL","AC",LRSS,LRIDT,LRX))
if 'LRX
QUIT
Begin DoDot:1
+15 IF LRY
IF LRY'=$PIECE(^LR(LRDFN,"PL",LRX,0),"^",2)
SET LRY=0
QUIT
+16 IF LRY=""
SET LRY=$PIECE(^LR(LRDFN,"PL",LRX,0),"^",2)
End DoDot:1
if LRY=0
QUIT
+17 ;
+18 SET LRONELAB("ON FILE")=LRY
+19 ;
+20 ; If all "on file" sections and all "incoming" sections have the same performing lab
+21 ; then mark the entire report as being performed by that lab.
+22 IF LRONELAB("ON FILE")=LRONELAB("INCOMING")
Begin DoDot:1
+23 KILL ^TMP("LRPL",$JOB)
+24 SET LRREF=LRDFN_","_LRSS_","_LRIDT_",0"
+25 SET ^TMP("LRPL",$JOB,1,LRREF)=LRONELAB("INCOMING")
End DoDot:1
QUIT
+26 ;
+27 ; If no "on file" lab and one "incoming" lab
+28 ; then mark entire report as being performed by the "incoming" lab.
+29 IF LRONELAB("ON FILE")=""
IF LRONELAB("INCOMING")
Begin DoDot:1
+30 KILL ^TMP("LRPL",$JOB)
+31 SET LRREF=LRDFN_","_LRSS_","_LRIDT_",0"
+32 SET ^TMP("LRPL",$JOB,1,LRREF)=LRONELAB("INCOMING")
End DoDot:1
QUIT
+33 ;
+34 ; Walk up tree to find parent reference that may cover this reference at a higher level
+35 SET LRREF=""
+36 FOR
SET LRREF=$ORDER(^TMP("LRPL",$JOB,1,LRREF))
if LRREF=""
QUIT
Begin DoDot:1
+37 SET LRPLAB=$PIECE(^TMP("LRPL",$JOB,1,LRREF),"^")
+38 IF LRSS="CH"
DO CHCHK
QUIT
+39 IF LRSS?1(1"MI",1"SP",1"CY",1"EM",1"AU")
DO MIAPCHK
End DoDot:1
+40 ;
+41 QUIT
+42 ;
+43 ;
CHCHK ; Find "on file" performing lab for a "CH" test result.
+1 ;
+2 SET LRZ=LRREF
DO CHKNODE
+3 QUIT
+4 ;
+5 ;
MIAPCHK ; Find performing lab for a MI or AP subscript reference
+1 ;
+2 SET LRZ=LRREF
DO CHKNODE
if LRY
QUIT
+3 IF $PIECE(LRREF,";",2)'=""
SET LRZ=$PIECE(LRREF,";")
DO CHKNODE
if LRY
QUIT
+4 ;
+5 SET LRJ=$LENGTH(LRZ,",")
+6 FOR LRK=LRJ:-1:4
Begin DoDot:1
+7 SET LRZ=$PIECE(LRZ,",",1,LRK)
DO CHKNODE
if LRY
QUIT
+8 IF $PIECE(LRZ,",",LRK)>0
SET $PIECE(LRZ,",",LRK)=0
DO CHKNODE
End DoDot:1
if LRY
QUIT
+9 ;
+10 IF LRSS="MI"
IF LRY=""
IF $PIECE(LRX,",",4)=99
FOR I=1,5,8,11,16
SET $PIECE(LRZ,",",4)=I
DO CHKNODE
if LRY
QUIT
+11 ;
+12 QUIT
+13 ;
+14 ;
CHKNODE ; Check if "on file" node or parent exists and delete "incoming" if it matches "on file" lab
+1 ;
+2 NEW LRI
+3 SET LRY=""
SET LRI=$ORDER(^LR(LRDFN,"PL","B",LRZ,0))
+4 IF LRI
SET LRY=$PIECE(^LR(LRDFN,"PL",LRI,0),"^",2)
+5 IF LRY
IF LRY=LRPLAB
KILL ^TMP("LRPL",$JOB,1,LRREF)
QUIT
+6 ;
+7 ; Check if "incoming" has a higher parent for the same lab.
+8 IF LRREF'=LRZ
Begin DoDot:1
+9 SET LRY=+$GET(^TMP("LRPL",$JOB,1,LRZ))
+10 IF LRY
IF LRY=LRPLAB
KILL ^TMP("LRPL",$JOB,1,LRREF)
End DoDot:1
+11 QUIT
+12 ;
+13 ;
TEST ; Entry point to test/debug
+1 ;
+2 NEW LRAA,LRAD,LRAN,LRACC,LRDFN,LRIDT,LRSS
+3 SET LRACC=1
+4 FOR
Begin DoDot:1
+5 WRITE !
+6 DO EN^LRWU4
+7 IF LRAA<1
QUIT
+8 SET LRDFN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^")
SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
+9 IF LRSS'="AU"
SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
+10 IF '$TEST
SET LRIDT=""
+11 IF LRSS="BB"
WRITE !,"Blood Bank not supported"
QUIT
+12 DO EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
+13 WRITE !!
End DoDot:1
if LRAA<1
QUIT
+14 ;
+15 QUIT
+16 ;
+17 ;
TEST2 ; Entry point test printing performing lab for an accession
+1 ;
+2 NEW LRAA,LRAD,LRAN,LRACC,LRDFN,LRIDT,LRPL,LRSS
+3 SET LRACC=1
+4 FOR
Begin DoDot:1
+5 WRITE !
+6 DO EN^LRWU4
+7 IF LRAA<1
QUIT
+8 SET LRDFN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^")
SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
+9 IF LRSS'="AU"
SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
+10 IF '$TEST
SET LRIDT=0
+11 IF LRSS="BB"
WRITE !,"Blood Bank not supported"
QUIT
+12 KILL LRPL
+13 DO RETLST^LRRPL(.LRPL,LRDFN,LRSS,LRIDT,0)
+14 IF '$ORDER(LRPL(0))
KILL LRPL
SET LRPL(1)="Performing Lab Sites: None Listed"
+15 IF '$TEST
SET LRPL(.5)="Performing Lab Sites:"
SET LRPL(.6)=" "
+16 WRITE !!
DO EN^DDIOL(.LRPL)
End DoDot:1
if LRAA<1
QUIT
+17 QUIT
NOASK ; Set reference to performing lab in file #63 If ASK PERFORMING LAB =NO
+1 ; Update if already set otherwise create a new record.
+2 ;
+3 NEW LRDPL,LRFLAG,LRREF,LRPLAB,LRSECT
+4 SET LRFLAG=0
SET LRSECT=0
+5 IF LRSS?1(1"MI",1"SP",1"CY",1"EM")
SET LRFLAG=1
+6 SET LRDPL=$$GET^XPAR("USR","LR VER DEFAULT PERFORMING LAB",1,"Q")
+7 IF LRDPL<1
SET LRDPL=DUZ(2)
+8 SET LRPLAB=LRDPL
+9 SET LRREF=LRDFN_","_LRSS_","_LRIDT_","_LRSECT
+10 ;
+11 WRITE !
+12 ; Update existing entry
+13 IF $DATA(^LR(LRDFN,"PL","B",LRREF))
Begin DoDot:1
+14 DO UEE^LRRPLU(LRDFN,LRREF,LRPLAB)
End DoDot:1
QUIT
+15 ;
+16 ; Create new entry
+17 DO CNE^LRRPLU(LRDFN,LRREF,LRPLAB)
+18 QUIT
