- LR7OGMC ;VA/DALOI/STAFF- Interim report rpc memo chem ; 03-Jul-2014 07:41 ; MKK
- ;;5.2;LAB SERVICE;**1027,1028,1031,1033**;NOV 01, 1997;Build 146
- ;
- ;;VA LR Patche(s): 187,230,312,286,356,372,395
- ;
- ; 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 CDT,CHSUB,CMNT,INTP,LABSUB,PNODE,PORDER,SPEC,TCNT,TESTNUM,TESTSUB,ZERO,ACC,NUM,AREA,ACDT,LRAAT,LRAD,UID,GOTNP
- 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),CDT=+ZERO,LABSUB="CH",TCNT=0,SPEC=$P(ZERO,U,5)
- D GETNP ;Check for NP comments
- I FORMAT,GOTNP S SKIP=1 Q
- I GOTNP,'$P(ZERO,"^",3) D Q
- . D ACC:UID
- . I $O(^TMP("LR7OG",$J,"TP",CDT,0)) K:FORMAT ^TMP("LR7OG",$J,"TP",CDT) D CHKNP Q
- D ACC:UID,VER
- I '$O(^TMP("LR7OG",$J,"TP",CDT,0)) S SKIP=1 Q
- I '$O(^LR(LRDFN,"CH",IDT,1)) D CHKNP
- I FORMAT D
- . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="0^CH^"_(9999999-IDT)
- . S OUTCNT=OUTCNT+1,DONE=1
- I FORMAT,'GOTNP D GRID^LR7OGMG(.OUTCNT)
- ; I 'FORMAT D PRINT^LR7OGMP(.OUTCNT)
- I 'FORMAT D PRINT^BLR7OGMP(.OUTCNT) ; IHS/MSC/MKK - LR*5.2*1031 - Restore LR*5.2*1028 Modification
- 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,"^",6)'="*Not Performed" Q:$P(ANODE,"^",5) ;complete date
- . I FORMAT,$P(ANODE,"^",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
- . I 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 $L(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 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 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))
- Q:'$D(^LR(LRDFN,LABSUB,IDT,TESTSUB)) Q:'$L($P($G(^(TESTSUB)),U)) ; IHS/MSC/MKK - LR*5.2*1033
- 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))=""
- I $P(LRX,U,6) S ^TMP("LRPLS",$J,$P(LRX,U,6))=$P($G(^LR(LRDFN,"CH",IDT,"RF")),"^",2,3) ; IHS/MSC/MKK - LR*5.2*1033
- 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
- ; I 'FORMAT D PRINT^LR7OGMP(.OUTCNT)
- I 'FORMAT D PRINT^BLR7OGMP(.OUTCNT) ; IHS/MSC/MKK - LR*5.2*1031
- K ^TMP("LR7OG",$J,"TP")
- Q
- GETNP ;Set NP flag (Not Performed)
- 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:"))
- Q:LRCAN<1
- I $G(FORMAT) Q:$O(^LR(LRDFN,"CH",IDT,1))
- S GOTNP=1
- Q
- LR7OGMC ;VA/DALOI/STAFF- Interim report rpc memo chem ; 03-Jul-2014 07:41 ; MKK
- +1 ;;5.2;LAB SERVICE;**1027,1028,1031,1033**;NOV 01, 1997;Build 146
- +2 ;
- +3 ;;VA LR Patche(s): 187,230,312,286,356,372,395
- +4 ;
- +5 ; sets lab data into ^TMP("LR7OG",$J,"TP"
- +6 ; ^TMP("LR7OG",$J,"G")=dfn^pnm^lrdfn^age^sex^lrcw
- +7 ; ^TMP("LR7OG",$J,"TMP",LR Subscript)=ifn of test from 60
- +8 ; ^TMP("LR7OG",$J,"T",ifn 60)=^LAB(60,IFN,0)
- +9 ; ^TMP("LR7OG",$J,"TP",collect date/time)=zero node from data
- +10 ; ^TMP("LR7OG",$J,"TP",collect date/time,printorder)=test#^name^printname^^printcode^dataname^result^flag^units^range^performing site
- +11 ; ^TMP("LR7OG",$J,"TP",collect date/time,printorder,#)=interpretation
- +12 ; ^TMP("LR7OG",$J,"TP",collect date/time,"C",#)=comment
- +13 ; ALL = 1 when coming from INTERIMG^LR7OGM (Most Recent)
- CH(LRDFN,IDT,ALL,OUTCNT,FORMAT,DONE,SKIP) ; from LR7OGM
- +1 NEW CDT,CHSUB,CMNT,INTP,LABSUB,PNODE,PORDER,SPEC,TCNT,TESTNUM,TESTSUB,ZERO,ACC,NUM,AREA,ACDT,LRAAT,LRAD,UID,GOTNP
- +2 SET GOTNP=0
- SET ZERO=$GET(^LR(LRDFN,"CH",IDT,0))
- SET UID=$PIECE($GET(^("ORU")),"^")
- +3 IF UID'=""
- SET UID=$$CHECKUID^LRWU4(UID)
- +4 SET AREA=$PIECE(UID,"^",2)
- SET ACDT=$PIECE(UID,"^",3)
- SET NUM=$PIECE(UID,"^",4)
- SET CDT=+ZERO
- SET LABSUB="CH"
- SET TCNT=0
- SET SPEC=$PIECE(ZERO,U,5)
- +5 ;Check for NP comments
- DO GETNP
- +6 IF FORMAT
- IF GOTNP
- SET SKIP=1
- QUIT
- +7 IF GOTNP
- IF '$PIECE(ZERO,"^",3)
- Begin DoDot:1
- +8 IF UID
- DO ACC
- +9 IF $ORDER(^TMP("LR7OG",$JOB,"TP",CDT,0))
- IF FORMAT
- KILL ^TMP("LR7OG",$JOB,"TP",CDT)
- DO CHKNP
- QUIT
- End DoDot:1
- QUIT
- +10 IF UID
- DO ACC
- DO VER
- +11 IF '$ORDER(^TMP("LR7OG",$JOB,"TP",CDT,0))
- SET SKIP=1
- QUIT
- +12 IF '$ORDER(^LR(LRDFN,"CH",IDT,1))
- DO CHKNP
- +13 IF FORMAT
- Begin DoDot:1
- +14 SET ^TMP("LR7OGX",$JOB,"OUTPUT",OUTCNT)="0^CH^"_(9999999-IDT)
- +15 SET OUTCNT=OUTCNT+1
- SET DONE=1
- End DoDot:1
- +16 IF FORMAT
- IF 'GOTNP
- DO GRID^LR7OGMG(.OUTCNT)
- +17 ; I 'FORMAT D PRINT^LR7OGMP(.OUTCNT)
- +18 ; IHS/MSC/MKK - LR*5.2*1031 - Restore LR*5.2*1028 Modification
- IF 'FORMAT
- DO PRINT^BLR7OGMP(.OUTCNT)
- +19 KILL ^TMP("LR7OG",$JOB,"TP")
- +20 QUIT
- ACC ;Check Accession
- +1 NEW ANODE,X0,LRODT,LRSN,LROD0,LROD1,X,STATUS,LROS
- +2 KILL ^TMP("LR7OG",$JOB,"ACC")
- +3 IF '$DATA(^LRO(68,+AREA,1,+ACDT,1,+NUM))
- QUIT
- +4 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))
- +5 SET TESTNUM=0
- FOR
- SET TESTNUM=$ORDER(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,TESTNUM))
- IF 'TESTNUM
- QUIT
- SET ANODE=^(TESTNUM,0)
- Begin DoDot:1
- +6 ;complete date
- IF $PIECE(ANODE,"^",6)'="*Not Performed"
- IF $PIECE(ANODE,"^",5)
- QUIT
- +7 ;Don't show NP'd results on Most Recent Report
- IF FORMAT
- IF $PIECE(ANODE,"^",6)="*Not Performed"
- QUIT
- +8 ;Selected test not in accession
- IF 'ALL
- IF '$DATA(^TMP("LR7OG",$JOB,"T",TESTNUM))
- IF '$DATA(TESTS(TESTNUM))
- QUIT
- +9 ;complete date on parent
- IF TESTNUM'=$PIECE(ANODE,"^",9)
- IF $PIECE($GET(^LRO(68,+AREA,1,+ACDT,1,+NUM,4,+$PIECE(ANODE,"^",9),0)),"^",5)
- QUIT
- +10 SET ^TMP("LR7OG",$JOB,"ACC",TESTNUM)=ANODE
- End DoDot:1
- +11 IF '$ORDER(^TMP("LR7OG",$JOB,"ACC",0))
- QUIT
- +12 SET TESTNUM=0
- FOR
- SET TESTNUM=$ORDER(^TMP("LR7OG",$JOB,"ACC",TESTNUM))
- IF 'TESTNUM
- QUIT
- SET ANODE=^(TESTNUM)
- Begin DoDot:1
- +13 IF '$DATA(^LAB(60,TESTNUM,.1))
- QUIT
- SET PNODE=^(.1)
- IF '("BO"[$PIECE($GET(^(0)),U,3))
- QUIT
- +14 SET PORDER=$PIECE(PNODE,U,6)
- SET PORDER=$SELECT(PORDER:PORDER,1:1/1000000)
- +15 FOR
- IF '$DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
- QUIT
- IF TESTNUM=+^(PORDER)
- QUIT
- SET PORDER=PORDER+1
- +16 IF $DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
- QUIT
- +17 SET LROS="Collected - Specimen In Lab"
- +18 IF $LENGTH(LROD1)
- SET X=$PIECE(LROD1,U,4)
- SET LROS=$SELECT(X="C":"Collected - Specimen In Lab",X="U":"Uncollected, cancelled",1:"On Collection List")
- +19 SET STATUS=$SELECT($PIECE(ANODE,"^",6)="*Not Performed":"Test Not Performed",1:LROS)
- +20 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
- +21 SET TCNT=TCNT+1
- End DoDot:1
- +22 KILL ^TMP("LR7OG",$JOB,"ACC")
- +23 IF TCNT
- SET ^TMP("LR7OG",$JOB,"TP",CDT)=ZERO
- +24 QUIT
- VER ;Check Verified Results
- +1 IF '$PIECE(ZERO,U,3)
- QUIT
- +2 IF ALL
- SET TESTSUB=1
- 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
- +3 IF 'ALL
- SET TESTSUB=1
- FOR
- SET TESTSUB=$ORDER(^TMP("LR7OG",$JOB,"TMP",TESTSUB))
- IF TESTSUB<1
- QUIT
- SET TESTNUM=+^(TESTSUB)
- DO CHSETUP
- +4 IF TCNT
- Begin DoDot:1
- +5 SET ^TMP("LR7OG",$JOB,"TP",CDT)=ZERO
- SET CMNT=0
- +6 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
- +7 QUIT
- CHSETUP ; within scope of CH
- +1 NEW LRX
- +2 IF 'TESTNUM
- QUIT
- +3 IF '$DATA(^LAB(60,TESTNUM,.1))
- QUIT
- SET PNODE=^(.1)
- IF '("BO"[$PIECE($GET(^(0)),U,3))
- QUIT
- +4 ;Q:'$D(^LR(LRDFN,LABSUB,IDT,TESTSUB)) Q:'$L($P(^(TESTSUB),U))
- +5 ; IHS/MSC/MKK - LR*5.2*1033
- IF '$DATA(^LR(LRDFN,LABSUB,IDT,TESTSUB))
- QUIT
- IF '$LENGTH($PIECE($GET(^(TESTSUB)),U))
- QUIT
- +6 SET PORDER=$PIECE(PNODE,U,6)
- SET PORDER=$SELECT(PORDER:PORDER,1:TESTSUB/1000000)
- +7 FOR
- IF '$DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
- QUIT
- IF TESTNUM=+^(PORDER)
- QUIT
- SET PORDER=PORDER+1
- +8 IF $DATA(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
- QUIT
- +9 SET LRX=$$TSTRES^LRRPU(LRDFN,LABSUB,IDT,TESTSUB,TESTNUM)
- +10 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)
- +11 ; Save performing lab ien in list
- +12 ; I $P(LRX,U,6) S ^TMP("LRPLS",$J,$P(LRX,U,6))=""
- +13 ; IHS/MSC/MKK - LR*5.2*1033
- IF $PIECE(LRX,U,6)
- SET ^TMP("LRPLS",$JOB,$PIECE(LRX,U,6))=$PIECE($GET(^LR(LRDFN,"CH",IDT,"RF")),"^",2,3)
- +14 SET TCNT=TCNT+1
- +15 IF $DATA(^LAB(60,TESTNUM,1,SPEC,1,0))
- Begin DoDot:1
- +16 SET INTP=0
- +17 FOR
- SET INTP=+$ORDER(^LAB(60,TESTNUM,1,SPEC,1,INTP))
- IF INTP<1
- QUIT
- Begin DoDot:2
- +18 SET ^TMP("LR7OG",$JOB,"TP",CDT,PORDER,INTP)=^(INTP,0)
- +19 SET TCNT=TCNT+1
- End DoDot:2
- End DoDot:1
- +20 QUIT
- CMT ; Retrieve specimen comments
- +1 SET ^TMP("LR7OG",$JOB,"TP",CDT)=ZERO
- SET CMNT=0
- +2 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
- +3 QUIT
- CHKNP ; Check for NP comments and no verified results.
- +1 NEW LRCAN,X
- +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 ; Print if cancel comment and no unverified results.
- +5 IF LRCAN<1
- QUIT
- +6 DO CMT
- +7 ; I 'FORMAT D PRINT^LR7OGMP(.OUTCNT)
- +8 ; IHS/MSC/MKK - LR*5.2*1031
- IF 'FORMAT
- DO PRINT^BLR7OGMP(.OUTCNT)
- +9 KILL ^TMP("LR7OG",$JOB,"TP")
- +10 QUIT
- GETNP ;Set NP flag (Not Performed)
- +1 NEW LRCAN,X
- +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 IF $GET(FORMAT)
- IF $ORDER(^LR(LRDFN,"CH",IDT,1))
- QUIT
- +6 SET GOTNP=1
- +7 QUIT
