LR7OGMC ;DALOI/STAFF- Interim report rpc memo chem ;July 29, 2019@10:00
;;5.2;LAB SERVICE;**187,230,312,286,356,372,395,350,516,523,527**;Sep 27, 1994;Build 16
;Per VHA Directive 2004-038, this routine should not be modified.
;
; sets lab data into ^TMP("LR7OG",$J,"TP"
; ^TMP("LR7OG",$J,"G")=dfn^pnm^lrdfn^age^sex^lrcw
; ^TMP("LR7OG",$J,"TMP",LR Subscript)=ifn of test from 60
; ^TMP("LR7OG",$J,"T",ifn 60)=^LAB(60,IFN,0)
; ^TMP("LR7OG",$J,"TP",collect date/time)=zero node from data
; ^TMP("LR7OG",$J,"TP",collect date/time,printorder)=test#^name^printname^^printcode^dataname^result^flag^units^range^performing site
; ^TMP("LR7OG",$J,"TP",collect date/time,printorder,#)=interpretation
; ^TMP("LR7OG",$J,"TP",collect date/time,"C",#)=comment
; ALL = 1 when coming from INTERIMG^LR7OGM (Most Recent)
;
;
CH(LRDFN,IDT,ALL,OUTCNT,FORMAT,DONE,SKIP) ; from LR7OGM
N ACC,AREA,ACDT,CDT,CHSUB,CMNT,GOTNP,INTP,LABSUB,LRAAT,LRAD,NUM,PNODE
N PORDER,SPEC,TCNT,TESTNUM,TESTSUB,UID,ZERO,LRORUT
;
S GOTNP=0,ZERO=$G(^LR(LRDFN,"CH",IDT,0)),UID=$P($G(^("ORU")),"^")
I UID'="" S UID=$$CHECKUID^LRWU4(UID)
S AREA=$P(UID,"^",2),ACDT=$P(UID,"^",3),NUM=$P(UID,"^",4)
S CDT=+ZERO,LABSUB="CH",TCNT=0,SPEC=$P(ZERO,U,5)
;
D GETNP ;Check for NP comments
;LR*5.2*527: commenting out line below so that "not performed" ordered
; tests will display.
;I FORMAT,GOTNP S SKIP=1 Q
I GOTNP,'$P(ZERO,U,3) D Q
. N LRXQUIT
. S LRXQUIT=1
. D ACC:UID
. ;LR*5.2*527: The line below would not have been called in the
. ; pre-LR 527 version of this routine because GOTNP=1
. ; and FORMAT=1.
. ; Leaving it here commented out in case it is needed
. ; in the future for some reason.
. ;I $O(^TMP("LR7OG",$J,"TP",CDT,0)) K:FORMAT ^TMP("LR7OG",$J,"TP",CDT) D CHKNP Q
. ;LR*5.2*527: adding logic to retrieve information for ordered tests
. ; which have been marked "not performed".
. S LRORUT=0
. F S LRORUT=$O(^LR(LRDFN,"CH",IDT,"ORUT",LRORUT)) Q:'LRORUT D
. . S TESTNUM=$P($G(^LR(LRDFN,"CH",IDT,"ORUT",LRORUT,0)),U,13)
. . Q:'TESTNUM
. . I '("BO"[$P($G(^LAB(60,TESTNUM,0)),U,3)) Q
. . Q:'$D(^LAB(60,TESTNUM,.1)) S PNODE=^(.1)
. . ;Checking for existence of "ALL" as well as value in case this option is called
. . ;from an option which only selects certain tests and is not the CPRS Labs Tab
. . ;"Selected Tests by Date" report.
. . ;Selected tests will be in ^TMP("LR7OG" and TESTS(TESTNUM)
. . ;Setting flag to check whether at least this test was selected.
. . I $D(ALL),'$G(ALL),$D(^TMP("LR7OG",$J,"T",TESTNUM)),$D(TESTS(TESTNUM)) S LRXQUIT=0
. . ;Do not display this test if it was not selected.
. . I $D(ALL),'$G(ALL),'$D(^TMP("LR7OG",$J,"T",TESTNUM)),'$D(TESTS(TESTNUM)) Q
. . S PORDER=$P(PNODE,U,6),PORDER=$S(PORDER:PORDER,1:1/1000000)
. . F Q:'$D(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:TESTNUM=+^(PORDER) S PORDER=PORDER+1
. . I $D(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q
. . S ^TMP("LR7OG",$J,"TP",CDT,PORDER)=TESTNUM_U_$P(^LAB(60,TESTNUM,0),U)_U_$P(PNODE,U)_U_$P(PNODE,U,2)_U_"X"_U_$P(^(0),U,5)_U_"Test Not Performed"
. ;Quit if no "not performed" tests were selected
. I $D(ALL),'$G(ALL),LRXQUIT Q
. S ^TMP("LR7OG",$J,"TP",CDT)=ZERO
. D CMT
. I 'FORMAT D PRINT^LR7OGMP(.OUTCNT)
. I FORMAT D
. . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="0^CH^"_(9999999-IDT)
. . S OUTCNT=OUTCNT+1,DONE=1
. . D GRID^LR7OGMG(.OUTCNT)
. K ^TMP("LR7OG",$J,"TP")
;LR*5.2*527: end of added lines in this section
;
D ACC:UID,VER
I '$O(^TMP("LR7OG",$J,"TP",CDT,0)) S SKIP=1 Q
;LR*5.2*527: Line below not changed. But this logic doesn't seem
; to cause an output because the same sort of check was
; done previously in this section at GETNP.
I '$O(^LR(LRDFN,"CH",IDT,1)) D CHKNP
;
;LR 523 quit out when only calling for info only for LR7OGM
I FORMAT=4 Q
;
I FORMAT D
. S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="0^CH^"_(9999999-IDT)
. S OUTCNT=OUTCNT+1,DONE=1
. ;LR*5.2*527: changing line below to not check for GOTNP
. ;I 'GOTNP D GRID^LR7OGMG(.OUTCNT)
. D GRID^LR7OGMG(.OUTCNT)
;
I 'FORMAT D PRINT^LR7OGMP(.OUTCNT)
;
K ^TMP("LR7OG",$J,"TP")
;
Q
;
;
ACC ;Check Accession
N ANODE,X0,LRODT,LRSN,LROD0,LROD1,X,STATUS,LROS
;
K ^TMP("LR7OG",$J,"ACC")
;
I '$D(^LRO(68,+AREA,1,+ACDT,1,+NUM)) Q
;
S X0=$G(^LRO(68,+AREA,1,+ACDT,1,+NUM,0)),LRODT=$P(X0,"^",4),LRSN=$P(X0,"^",5),LROD0=$G(^LRO(69,+LRODT,1,LRSN,0)),LROD1=$G(^(1))
;
S TESTNUM=0
F S TESTNUM=$O(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM)) Q:'TESTNUM S ANODE=^(TESTNUM,0) D
. I $P(ANODE,U,6)'="*Not Performed" Q:$P(ANODE,U,5) ;complete date
. ;LR*5.2*527: commenting out line below so that NP'd tests will display
. ;I FORMAT,$P(ANODE,U,6)="*Not Performed" Q ;Don't show NP'd results on Most Recent Report
. I 'ALL,'$D(^TMP("LR7OG",$J,"T",TESTNUM)),'$D(TESTS(TESTNUM)) Q ;Selected test not in accession
. ;LR*5.2*527: adding"*Not Performed" check so that NP'd tests will display
. ; ^TMP("LR7OG",$J,"TP" will be set up below for NP'd tests.
. ; ^TMP("LR7OG",$J,"TP" is set up at VER for other tests.
. I $P(ANODE,U,6)'="*Not Performed",TESTNUM'=$P(ANODE,"^",9),$P($G(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,+$P(ANODE,"^",9),0)),"^",5) Q ;complete date on parent
. S ^TMP("LR7OG",$J,"ACC",TESTNUM)=ANODE
;
I '$O(^TMP("LR7OG",$J,"ACC",0)) Q
;
S TESTNUM=0
F S TESTNUM=$O(^TMP("LR7OG",$J,"ACC",TESTNUM)) Q:'TESTNUM S ANODE=^(TESTNUM) D
. Q:'$D(^LAB(60,TESTNUM,.1)) S PNODE=^(.1) I '("BO"[$P($G(^(0)),U,3)) Q
. S PORDER=$P(PNODE,U,6),PORDER=$S(PORDER:PORDER,1:1/1000000)
. F Q:'$D(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:TESTNUM=+^(PORDER) S PORDER=PORDER+1
. I $D(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q
. S LROS="Collected - Specimen In Lab"
. I LROD1'="" S X=$P(LROD1,U,4),LROS=$S(X="C":"Collected - Specimen In Lab",X="U":"Uncollected, cancelled",1:"On Collection List")
. S STATUS=$S($P(ANODE,"^",6)="*Not Performed":"Test Not Performed",1:LROS)
. S ^TMP("LR7OG",$J,"TP",CDT,PORDER)=TESTNUM_U_$P(^LAB(60,TESTNUM,0),U)_U_$P(PNODE,U)_U_$P(PNODE,U,2)_U_"X"_U_$P(^(0),U,5)_U_STATUS
. S TCNT=TCNT+1
;
K ^TMP("LR7OG",$J,"ACC")
I TCNT S ^TMP("LR7OG",$J,"TP",CDT)=ZERO
;
Q
;
;
VER ; Check Verified Results
Q:'$P(ZERO,U,3)
;
I ALL D
. S TESTSUB=1
. F S TESTSUB=$O(^LR(LRDFN,"CH",IDT,TESTSUB)) Q:TESTSUB<1 S TESTNUM=$O(^LAB(60,"C","CH;"_TESTSUB_";1",0)) D CHSETUP
;
I 'ALL D
. S TESTSUB=1
. F S TESTSUB=$O(^TMP("LR7OG",$J,"TMP",TESTSUB)) Q:TESTSUB<1 S TESTNUM=+^(TESTSUB) D CHSETUP
;
I TCNT D
. S ^TMP("LR7OG",$J,"TP",CDT)=ZERO,CMNT=0
. F S CMNT=+$O(^LR(LRDFN,LABSUB,IDT,1,CMNT)) Q:CMNT<1 S ^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)=^(CMNT,0) S TCNT=TCNT+1
Q
;
;
CHSETUP ; within scope of CH
;
N LRX
I 'TESTNUM Q
Q:'$D(^LAB(60,TESTNUM,.1)) S PNODE=^(.1) I '("BO"[$P($G(^(0)),U,3)) Q
Q:'$D(^LR(LRDFN,LABSUB,IDT,TESTSUB)) Q:'$L($P(^(TESTSUB),U))
;
S PORDER=$P(PNODE,U,6),PORDER=$S(PORDER:PORDER,1:TESTSUB/1000000)
F Q:'$D(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:TESTNUM=+^(PORDER) S PORDER=PORDER+1
;
I $D(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q
;
S LRX=$$TSTRES^LRRPU(LRDFN,LABSUB,IDT,TESTSUB,TESTNUM)
S ^TMP("LR7OG",$J,"TP",CDT,PORDER)=TESTNUM_U_$P(^LAB(60,TESTNUM,0),U)_U_$P(PNODE,U)_U_$P(PNODE,U,2)_U_$P(PNODE,U,3)_U_$P(^(0),U,5)_U_$P(LRX,U)_U_$P(LRX,U,2)_U_$P(LRX,U,5)_U_$$EN^LRLRRVF($P(LRX,U,3),$P(LRX,U,4))_U_$P(LRX,U,6)
;
; Save performing lab ien in list
I $P(LRX,U,6) S ^TMP("LRPLS",$J,$P(LRX,U,6))=""
;
S TCNT=TCNT+1
I $D(^LAB(60,TESTNUM,1,SPEC,1,0)) D
. S INTP=0
. F S INTP=+$O(^LAB(60,TESTNUM,1,SPEC,1,INTP)) Q:INTP<1 D
. . S ^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)=^(INTP,0)
. . S TCNT=TCNT+1
Q
;
;
CMT ; Retrieve specimen comments
;
S ^TMP("LR7OG",$J,"TP",CDT)=ZERO,CMNT=0
F S CMNT=+$O(^LR(LRDFN,LABSUB,IDT,1,CMNT)) Q:CMNT<1 S ^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)=^(CMNT,0) S TCNT=TCNT+1
;
Q
;
;
CHKNP ; Check for NP comments and no verified results.
;
N LRCAN,X
S LRCAN=0
F S LRCAN=+$O(^LR(LRDFN,"CH",IDT,1,LRCAN)) Q:LRCAN<1 S X=^(LRCAN,0) Q:(($E(X)="*")&(X["Not Performed:"))
;
; Print if cancel comment and no unverified results.
I LRCAN<1 Q
D CMT
D PRINT^LR7OGMP(.OUTCNT)
K ^TMP("LR7OG",$J,"TP")
Q
;
;
GETNP ;Set NP flag (Not Performed)
N LRCAN,X,LRNPCNT
S LRCAN=0
F S LRCAN=+$O(^LR(LRDFN,"CH",IDT,1,LRCAN)) Q:LRCAN<1 S X=^(LRCAN,0) Q:(($E(X)="*")&(X["Not Performed:"))
Q:LRCAN<1
;LR*5.2*527: Commenting out line below so that not performed comments
; will display if test results are entered but not yet
; verified. The non-verified results will not display.
;I $G(FORMAT) Q:$O(^LR(LRDFN,"CH",IDT,1))
S GOTNP=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OGMC 8845 printed Sep 23, 2025@19:40:49 Page 2
LR7OGMC ;DALOI/STAFF- Interim report rpc memo chem ;July 29, 2019@10:00
+1 ;;5.2;LAB SERVICE;**187,230,312,286,356,372,395,350,516,523,527**;Sep 27, 1994;Build 16
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; sets lab data into ^TMP("LR7OG",$J,"TP"
+5 ; ^TMP("LR7OG",$J,"G")=dfn^pnm^lrdfn^age^sex^lrcw
+6 ; ^TMP("LR7OG",$J,"TMP",LR Subscript)=ifn of test from 60
+7 ; ^TMP("LR7OG",$J,"T",ifn 60)=^LAB(60,IFN,0)
+8 ; ^TMP("LR7OG",$J,"TP",collect date/time)=zero node from data
+9 ; ^TMP("LR7OG",$J,"TP",collect date/time,printorder)=test#^name^printname^^printcode^dataname^result^flag^units^range^performing site
+10 ; ^TMP("LR7OG",$J,"TP",collect date/time,printorder,#)=interpretation
+11 ; ^TMP("LR7OG",$J,"TP",collect date/time,"C",#)=comment
+12 ; ALL = 1 when coming from INTERIMG^LR7OGM (Most Recent)
+13 ;
+14 ;
CH(LRDFN,IDT,ALL,OUTCNT,FORMAT,DONE,SKIP) ; from LR7OGM
+1 NEW ACC,AREA,ACDT,CDT,CHSUB,CMNT,GOTNP,INTP,LABSUB,LRAAT,LRAD,NUM,PNODE
+2 NEW PORDER,SPEC,TCNT,TESTNUM,TESTSUB,UID,ZERO,LRORUT
+3 ;
+4 SET GOTNP=0
SET ZERO=$GET(^LR(LRDFN,"CH",IDT,0))
SET UID=$PIECE($GET(^("ORU")),"^")
+5 IF UID'=""
SET UID=$$CHECKUID^LRWU4(UID)
+6 SET AREA=$PIECE(UID,"^",2)
SET ACDT=$PIECE(UID,"^",3)
SET NUM=$PIECE(UID,"^",4)
+7 SET CDT=+ZERO
SET LABSUB="CH"
SET TCNT=0
SET SPEC=$PIECE(ZERO,U,5)
+8 ;
+9 ;Check for NP comments
DO GETNP
+10 ;LR*5.2*527: commenting out line below so that "not performed" ordered
+11 ; tests will display.
+12 ;I FORMAT,GOTNP S SKIP=1 Q
+13 IF GOTNP
IF '$PIECE(ZERO,U,3)
Begin DoDot:1
+14 NEW LRXQUIT
+15 SET LRXQUIT=1
+16 if UID
DO ACC
+17 ;LR*5.2*527: The line below would not have been called in the
+18 ; pre-LR 527 version of this routine because GOTNP=1
+19 ; and FORMAT=1.
+20 ; Leaving it here commented out in case it is needed
+21 ; in the future for some reason.
+22 ;I $O(^TMP("LR7OG",$J,"TP",CDT,0)) K:FORMAT ^TMP("LR7OG",$J,"TP",CDT) D CHKNP Q
+23 ;LR*5.2*527: adding logic to retrieve information for ordered tests
+24 ; which have been marked "not performed".
+25 SET LRORUT=0
+26 FOR
SET LRORUT=$ORDER(^LR(LRDFN,"CH",IDT,"ORUT",LRORUT))
if 'LRORUT
QUIT
Begin DoDot:2
+27 SET TESTNUM=$PIECE($GET(^LR(LRDFN,"CH",IDT,"ORUT",LRORUT,0)),U,13)
+28 if 'TESTNUM
QUIT
+29 IF '("BO"[$PIECE($GET(^LAB(60,TESTNUM,0)),U,3))
QUIT
+30 if '$DATA(^LAB(60,TESTNUM,.1))
QUIT
SET PNODE=^(.1)
+31 ;Checking for existence of "ALL" as well as value in case this option is called
+32 ;from an option which only selects certain tests and is not the CPRS Labs Tab
+33 ;"Selected Tests by Date" report.
+34 ;Selected tests will be in ^TMP("LR7OG" and TESTS(TESTNUM)
+35 ;Setting flag to check whether at least this test was selected.
+36 IF $DATA(ALL)
IF '$GET(ALL)
IF $DATA(^TMP("LR7OG",$JOB,"T",TESTNUM))
IF $DATA(TESTS(TESTNUM))
SET LRXQUIT=0
+37 ;Do not display this test if it was not selected.
+38 IF $DATA(ALL)
IF '$GET(ALL)
IF '$DATA(^TMP("LR7OG",$JOB,"T",TESTNUM))
IF '$DATA(TESTS(TESTNUM))
QUIT
+39 SET PORDER=$PIECE(PNODE,U,6)
SET PORDER=$SELECT(PORDER:PORDER,1:1/1000000)
+40 FOR
if '$DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
QUIT
if TESTNUM=+^(PORDER)
QUIT
SET PORDER=PORDER+1
+41 IF $DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
QUIT
+42 SET ^TMP("LR7OG",$JOB,"TP",CDT,PORDER)=TESTNUM_U_$PIECE(^LAB(60,TESTNUM,0),U)_U_$PIECE(PNODE,U)_U_$PIECE(PNODE,U,2)_U_"X"_U_$PIECE(^(0),U,5)_U_"Test Not Performed"
End DoDot:2
+43 ;Quit if no "not performed" tests were selected
+44 IF $DATA(ALL)
IF '$GET(ALL)
IF LRXQUIT
QUIT
+45 SET ^TMP("LR7OG",$JOB,"TP",CDT)=ZERO
+46 DO CMT
+47 IF 'FORMAT
DO PRINT^LR7OGMP(.OUTCNT)
+48 IF FORMAT
Begin DoDot:2
+49 SET ^TMP("LR7OGX",$JOB,"OUTPUT",OUTCNT)="0^CH^"_(9999999-IDT)
+50 SET OUTCNT=OUTCNT+1
SET DONE=1
+51 DO GRID^LR7OGMG(.OUTCNT)
End DoDot:2
+52 KILL ^TMP("LR7OG",$JOB,"TP")
End DoDot:1
QUIT
+53 ;LR*5.2*527: end of added lines in this section
+54 ;
+55 if UID
DO ACC
DO VER
+56 IF '$ORDER(^TMP("LR7OG",$JOB,"TP",CDT,0))
SET SKIP=1
QUIT
+57 ;LR*5.2*527: Line below not changed. But this logic doesn't seem
+58 ; to cause an output because the same sort of check was
+59 ; done previously in this section at GETNP.
+60 IF '$ORDER(^LR(LRDFN,"CH",IDT,1))
DO CHKNP
+61 ;
+62 ;LR 523 quit out when only calling for info only for LR7OGM
+63 IF FORMAT=4
QUIT
+64 ;
+65 IF FORMAT
Begin DoDot:1
+66 SET ^TMP("LR7OGX",$JOB,"OUTPUT",OUTCNT)="0^CH^"_(9999999-IDT)
+67 SET OUTCNT=OUTCNT+1
SET DONE=1
+68 ;LR*5.2*527: changing line below to not check for GOTNP
+69 ;I 'GOTNP D GRID^LR7OGMG(.OUTCNT)
+70 DO GRID^LR7OGMG(.OUTCNT)
End DoDot:1
+71 ;
+72 IF 'FORMAT
DO PRINT^LR7OGMP(.OUTCNT)
+73 ;
+74 KILL ^TMP("LR7OG",$JOB,"TP")
+75 ;
+76 QUIT
+77 ;
+78 ;
ACC ;Check Accession
+1 NEW ANODE,X0,LRODT,LRSN,LROD0,LROD1,X,STATUS,LROS
+2 ;
+3 KILL ^TMP("LR7OG",$JOB,"ACC")
+4 ;
+5 IF '$DATA(^LRO(68,+AREA,1,+ACDT,1,+NUM))
QUIT
+6 ;
+7 SET X0=$GET(^LRO(68,+AREA,1,+ACDT,1,+NUM,0))
SET LRODT=$PIECE(X0,"^",4)
SET LRSN=$PIECE(X0,"^",5)
SET LROD0=$GET(^LRO(69,+LRODT,1,LRSN,0))
SET LROD1=$GET(^(1))
+8 ;
+9 SET TESTNUM=0
+10 FOR
SET TESTNUM=$ORDER(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM))
if 'TESTNUM
QUIT
SET ANODE=^(TESTNUM,0)
Begin DoDot:1
+11 ;complete date
IF $PIECE(ANODE,U,6)'="*Not Performed"
if $PIECE(ANODE,U,5)
QUIT
+12 ;LR*5.2*527: commenting out line below so that NP'd tests will display
+13 ;I FORMAT,$P(ANODE,U,6)="*Not Performed" Q ;Don't show NP'd results on Most Recent Report
+14 ;Selected test not in accession
IF 'ALL
IF '$DATA(^TMP("LR7OG",$JOB,"T",TESTNUM))
IF '$DATA(TESTS(TESTNUM))
QUIT
+15 ;LR*5.2*527: adding"*Not Performed" check so that NP'd tests will display
+16 ; ^TMP("LR7OG",$J,"TP" will be set up below for NP'd tests.
+17 ; ^TMP("LR7OG",$J,"TP" is set up at VER for other tests.
+18 ;complete date on parent
IF $PIECE(ANODE,U,6)'="*Not Performed"
IF TESTNUM'=$PIECE(ANODE,"^",9)
IF $PIECE($GET(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,+$PIECE(ANODE,"^",9),0)),"^",5)
QUIT
+19 SET ^TMP("LR7OG",$JOB,"ACC",TESTNUM)=ANODE
End DoDot:1
+20 ;
+21 IF '$ORDER(^TMP("LR7OG",$JOB,"ACC",0))
QUIT
+22 ;
+23 SET TESTNUM=0
+24 FOR
SET TESTNUM=$ORDER(^TMP("LR7OG",$JOB,"ACC",TESTNUM))
if 'TESTNUM
QUIT
SET ANODE=^(TESTNUM)
Begin DoDot:1
+25 if '$DATA(^LAB(60,TESTNUM,.1))
QUIT
SET PNODE=^(.1)
IF '("BO"[$PIECE($GET(^(0)),U,3))
QUIT
+26 SET PORDER=$PIECE(PNODE,U,6)
SET PORDER=$SELECT(PORDER:PORDER,1:1/1000000)
+27 FOR
if '$DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
QUIT
if TESTNUM=+^(PORDER)
QUIT
SET PORDER=PORDER+1
+28 IF $DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
QUIT
+29 SET LROS="Collected - Specimen In Lab"
+30 IF LROD1'=""
SET X=$PIECE(LROD1,U,4)
SET LROS=$SELECT(X="C":"Collected - Specimen In Lab",X="U":"Uncollected, cancelled",1:"On Collection List")
+31 SET STATUS=$SELECT($PIECE(ANODE,"^",6)="*Not Performed":"Test Not Performed",1:LROS)
+32 SET ^TMP("LR7OG",$JOB,"TP",CDT,PORDER)=TESTNUM_U_$PIECE(^LAB(60,TESTNUM,0),U)_U_$PIECE(PNODE,U)_U_$PIECE(PNODE,U,2)_U_"X"_U_$PIECE(^(0),U,5)_U_STATUS
+33 SET TCNT=TCNT+1
End DoDot:1
+34 ;
+35 KILL ^TMP("LR7OG",$JOB,"ACC")
+36 IF TCNT
SET ^TMP("LR7OG",$JOB,"TP",CDT)=ZERO
+37 ;
+38 QUIT
+39 ;
+40 ;
VER ; Check Verified Results
+1 if '$PIECE(ZERO,U,3)
QUIT
+2 ;
+3 IF ALL
Begin DoDot:1
+4 SET TESTSUB=1
+5 FOR
SET TESTSUB=$ORDER(^LR(LRDFN,"CH",IDT,TESTSUB))
if TESTSUB<1
QUIT
SET TESTNUM=$ORDER(^LAB(60,"C","CH;"_TESTSUB_";1",0))
DO CHSETUP
End DoDot:1
+6 ;
+7 IF 'ALL
Begin DoDot:1
+8 SET TESTSUB=1
+9 FOR
SET TESTSUB=$ORDER(^TMP("LR7OG",$JOB,"TMP",TESTSUB))
if TESTSUB<1
QUIT
SET TESTNUM=+^(TESTSUB)
DO CHSETUP
End DoDot:1
+10 ;
+11 IF TCNT
Begin DoDot:1
+12 SET ^TMP("LR7OG",$JOB,"TP",CDT)=ZERO
SET CMNT=0
+13 FOR
SET CMNT=+$ORDER(^LR(LRDFN,LABSUB,IDT,1,CMNT))
if CMNT<1
QUIT
SET ^TMP("LR7OG",$JOB,"TP",CDT,"C",CMNT)=^(CMNT,0)
SET TCNT=TCNT+1
End DoDot:1
+14 QUIT
+15 ;
+16 ;
CHSETUP ; within scope of CH
+1 ;
+2 NEW LRX
+3 IF 'TESTNUM
QUIT
+4 if '$DATA(^LAB(60,TESTNUM,.1))
QUIT
SET PNODE=^(.1)
IF '("BO"[$PIECE($GET(^(0)),U,3))
QUIT
+5 if '$DATA(^LR(LRDFN,LABSUB,IDT,TESTSUB))
QUIT
if '$LENGTH($PIECE(^(TESTSUB),U))
QUIT
+6 ;
+7 SET PORDER=$PIECE(PNODE,U,6)
SET PORDER=$SELECT(PORDER:PORDER,1:TESTSUB/1000000)
+8 FOR
if '$DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
QUIT
if TESTNUM=+^(PORDER)
QUIT
SET PORDER=PORDER+1
+9 ;
+10 IF $DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
QUIT
+11 ;
+12 SET LRX=$$TSTRES^LRRPU(LRDFN,LABSUB,IDT,TESTSUB,TESTNUM)
+13 SET ^TMP("LR7OG",$JOB,"TP",CDT,PORDER)=TESTNUM_U_$PIECE(^LAB(60,TESTNUM,0),U)_U_$PIECE(PNODE,U)_U_$PIECE(PNODE,U,2)_U_$PIECE(PNODE,U,3)_U_$PIECE(^(0),U,5)_U_$PIECE(LRX,U)_U_...
... $PIECE(LRX,U,2)_U_$PIECE(LRX,U,5)_U_$$EN^LRLRRVF($PIECE(LRX,U,3),$PIECE(LRX,U,4))_U_$PIECE(LRX,U,6)
+14 ;
+15 ; Save performing lab ien in list
+16 IF $PIECE(LRX,U,6)
SET ^TMP("LRPLS",$JOB,$PIECE(LRX,U,6))=""
+17 ;
+18 SET TCNT=TCNT+1
+19 IF $DATA(^LAB(60,TESTNUM,1,SPEC,1,0))
Begin DoDot:1
+20 SET INTP=0
+21 FOR
SET INTP=+$ORDER(^LAB(60,TESTNUM,1,SPEC,1,INTP))
if INTP<1
QUIT
Begin DoDot:2
+22 SET ^TMP("LR7OG",$JOB,"TP",CDT,PORDER,INTP)=^(INTP,0)
+23 SET TCNT=TCNT+1
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
+26 ;
CMT ; Retrieve specimen comments
+1 ;
+2 SET ^TMP("LR7OG",$JOB,"TP",CDT)=ZERO
SET CMNT=0
+3 FOR
SET CMNT=+$ORDER(^LR(LRDFN,LABSUB,IDT,1,CMNT))
if CMNT<1
QUIT
SET ^TMP("LR7OG",$JOB,"TP",CDT,"C",CMNT)=^(CMNT,0)
SET TCNT=TCNT+1
+4 ;
+5 QUIT
+6 ;
+7 ;
CHKNP ; Check for NP comments and no verified results.
+1 ;
+2 NEW LRCAN,X
+3 SET LRCAN=0
+4 FOR
SET LRCAN=+$ORDER(^LR(LRDFN,"CH",IDT,1,LRCAN))
if LRCAN<1
QUIT
SET X=^(LRCAN,0)
if (($EXTRACT(X)="*")&(X["Not Performed
QUIT
+5 ;
+6 ; Print if cancel comment and no unverified results.
+7 IF LRCAN<1
QUIT
+8 DO CMT
+9 DO PRINT^LR7OGMP(.OUTCNT)
+10 KILL ^TMP("LR7OG",$JOB,"TP")
+11 QUIT
+12 ;
+13 ;
GETNP ;Set NP flag (Not Performed)
+1 NEW LRCAN,X,LRNPCNT
+2 SET LRCAN=0
+3 FOR
SET LRCAN=+$ORDER(^LR(LRDFN,"CH",IDT,1,LRCAN))
if LRCAN<1
QUIT
SET X=^(LRCAN,0)
if (($EXTRACT(X)="*")&(X["Not Performed
QUIT
+4 if LRCAN<1
QUIT
+5 ;LR*5.2*527: Commenting out line below so that not performed comments
+6 ; will display if test results are entered but not yet
+7 ; verified. The non-verified results will not display.
+8 ;I $G(FORMAT) Q:$O(^LR(LRDFN,"CH",IDT,1))
+9 SET GOTNP=1
+10 QUIT
