- LRHYB ;DALOI/HOAK - HOWDY B DRIVER ;Sep 16, 2000
- ;;5.2;LAB SERVICE;**405,417,446,457,467,491,573**;Sep 27, 1994;Build 7
- ;
- TEST ;
- S DIC=2 S DIC(0)="AEMQZ" D ^DIC
- Q:Y=-1
- S LRDFN=$G(^DPT(+Y,"LR"))
- ;
- ;
- ;
- ORDCHK ; Here is where the search for an order number starts
- K LRHYT654
- ; The Howdy site file will help determine which orders the site
- ; will accept. Once an order has been selected it is handed off
- ; to LRORDST to start the accessioning process.
- ;
- N LRNAAAC
- K LRWCZZZ,LRDTF
- K LRHYCS33
- K ^TMP("LRHYDY",$J,"KILL")
- ;
- ;
- K ^TMP("LRHYDY",$J,"MULTD")
- K ^TMP("LRHYDY",$J,"DUPTEST")
- K LRHYCS
- K ^TMP("LRHYDY",$J,"MT")
- S LRHOWDY=1
- S LREND=0
- S LRORD=""
- Q:'LRDFN
- ;
- K ^TMP("LRHYDY",$J,"LRSN"),LRNPZZX
- S LRHYOK=0
- ;
- ; 18 days ahead
- ; 20 days back
- ;
- S X2=0 K LRNPZZX
- S LRAHEAD=$G(^LRHY(69.86,LRHYSITE,18))
- S LRPAST=$G(^LRHY(69.86,LRHYSITE,20))
- K LRWCZZZ,LREXORD
- S LRLOCS=0 ; flag for non-EXLOC and EXLOC on same specimen number
- F LRI=-LRPAST:1:LRAHEAD D Q:$G(LRLOCS) ;Search window set by site file.
- . S X1=DT S X2=LRI D C^%DTC S LR3DTN=X
- . I $D(^LRO(69,LR3DTN,1,"AA",LRDFN)) S LRHYOK=1 D
- .. S LR3SN=0
- .. F S LR3SN=$O(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN)) Q:+LR3SN'>0 D Q:$G(LRLOCS)
- ... Q:$P($G(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C" ;collected
- ... K LRWCZZZ
- ... ;
- ... K LRCOL99 S LRCOL99=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
- ... K LRCSTAT S LRCSTAT=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
- ... D CSTATUS^LRHYA Q:LRHYHOK ;Check collection status
- ... ;
- ... ;LR573 check for accession area conflict:
- ... S LRORD=^LRO(69,LR3DTN,1,LR3SN,.1) I '$$Q18^LROE2(DUZ(2)) S (LRLAAX,LRHYHOK)=1
- ... Q:LRHYHOK
- ... ;
- ... D OLT^LRHYA ;print order label tests
- ... Q:LRHYHOK
- ... ;
- ... ;
- ... K LRNOTST
- ... S LRNODUP=0 D LTE^LRHYA Q:LRHYHOK ;check for excluded lab tests
- ... ;
- ... S LRORD=^LRO(69,LR3DTN,1,LR3SN,.1)
- ... S LRLLOC66=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
- ... D EXLOC^LRHYA Q:LRHYHOK ;check for locations to exclude
- ... ;
- ... S LRLLOC=$G(LRLLOC66)
- ... S LRORD24=0
- ... D OLT^LRHYA Q:LRHYHOK ;print order label tests
- ... ;
- ... D URG^LRHYA Q:LRHYHOK ;; CHECK URGENCY
- ... K LRCOL99 S LRCOL99=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
- ... D CSE^LRHYA Q:LRHYHOK ;check for excluded collection samples
- ... ;
- ... I $O(^TMP("LRHYDY",$J,"EXLOC",LRORD,0))=$G(LRLLOC66) I $O(^LRO(69,"C",LRORD,0))'=DT QUIT
- ... ; CHECK URGENCY
- ... S LRTST6=0 ; micro test
- ... F S LRTST6=$O(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTST6)) Q:+LRTST6'>0 D
- .... S LRTSTZ99(LRTST6)=""
- .... I LRTST6 S LRSUB1=$P(^LAB(60,LRTST6,0),U,4) ; subscript
- .... Q:$D(LRNPZZX(^LRO(69,LR3DTN,1,LR3SN,.1),LR3SN,LRTST6))
- .... S LRORD=$G(^LRO(69,LR3DTN,1,LR3SN,.1))
- .... I $G(LRORD) I $D(^TMP("LRHYDY",$J,"STATUS",LRORD)) QUIT
- .... I $D(LRNOTST) I $D(LRNOTST(LRTST6)) K LRORD QUIT
- .... S ^TMP("LRHYDY",$J,"LRSN",LR3DTN,^LRO(69,LR3DTN,1,LR3SN,.1))=""
- .... S LRDTX=""
- .... S LRDTX=$O(^LRO(69,"C",^LRO(69,LR3DTN,1,LR3SN,.1),0))
- .... I $D(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66)),LR3DTN=DT,$G(LRDTX) S ^TMP("LRHYDY",$J,"MT",LRDTX)=""
- .... I '$D(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66)) I $G(LRDTX) S ^TMP("LRHYDY",$J,"MT",LRDTX)=""
- ;
- ;
- K LRMULT
- I $G(LRWCMULT) W !!!!,"Multple Orders Present" S LRMULT=1 D LOG1^LRHY0 K LRWCMULT QUIT
- ; per Libba 1/14/2002
- I $D(^TMP("LRHYDY",$J,"LRSN",DT)) S LR3DTN=DT ; I prefer today's orders but...
- E S LR3DTN=$O(^TMP("LRHYDY",$J,"LRSN",0)) ; I'll take whatever ya got
- I 'LR3DTN K LRORD QUIT
- ;
- I '$D(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66)) I $O(^TMP("LRHYDY",$J,"LRSN",LR3DTN)) W !,"MULTIPLE DAYS WITH ORDERS" S LRMULT=1 D LOG1^LRHY0 QUIT
- ;
- S LRTIC=0
- S LRMULT=0
- ;
- F S LRTIC=$O(^TMP("LRHYDY",$J,"LRSN",LRTIC)) Q:+LRTIC'>0 S LRMULT=LRMULT+1
- I '$D(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66)) I LRMULT>1 W !,"MULTIPLE DAYS WITH ORDERS" S LRMULT=0 D LOG1^LRHY0 QUIT
- ;MODIFIED BY HOAK to flag when wc and sp are on same visit
- ;
- ;
- MOVE ;
- I $D(LRNOTST) I $G(LRHYT654) I $D(LRNOTST(LRHYT654)) K LRORD QUIT
- I $G(LRORD),$D(LREXORD(LRORD)) K LRORD QUIT
- S LRHY3SN3=0
- S LRHY3DT3=0
- I $G(LRORD),$D(^TMP("LRHYDY",$J,"URG",LRORD)) K LRORD QUIT
- I $D(^LRHY(69.86,LRHYSITE,30,"B",LRURGZ19)) K LRORD QUIT
- S LRTIC=0
- S LRMULT=0
- F S LRTIC=$O(^TMP("LRHYDY",$J,"MT",LRTIC)) Q:+LRTIC'>0 S LRMULT=LRMULT+1
- S LR3MULT=LRMULT
- I LRMULT>1 W !,"MULTIPLE DAYS WITH ORDERS" S LRORD=0 QUIT
- E S LRMULT=0
- ; may be accessioned.
- ; Setting up task to continue based on the specimen.
- K LR3ZTST
- MOVE1 ;
- S LRORD=0
- F S LRORD=$O(^TMP("LRHYDY",$J,"LRSN",LR3DTN,LRORD)) Q:+LRORD'>0 D
- . S:'$G(LR3ORD) LR3ORD=LRORD
- . I $D(^TMP("LRHYDY",$J,"URG",LRORD)) QUIT
- . S LRHYORDZ=LRORD
- . ;
- . S ZTSAVE("^TMP(""LRHYDY"",$J,")=""
- . S ZTRTN="PAST^LRHYPH0",ZTSAVE("L*")="",ZTDTH=$H,ZTDESC="HOWDY"
- . S ZTIO="NULL"
- . S ZTSAVE("L*")=""
- . S:$D(ZTQUEUED) ZTREQ="@" D ^%ZTLOAD
- . S LRGOTIT=1
- . S LRORD=LRHYORDZ
- . K LRSTOPZ(LRORD)
- K ^TMP("LRHYDY",$J,"MULTD")
- S LRORD=$G(LR3ORD) K LR3ORD
- K LRHOWDY,LR3SN24,LR3DTN24,LR3ZTST,LROLT1,LRNAAAC
- I $G(LRORD) I $D(LRSTOPZ(LRORD)) K LRORD,LRSTOPZ QUIT
- ;
- QUIT
- ;
- MMM ;
- N LRI S LRI=0
- N LR3DTN,LR3SN,LRIENZZ,LRTSTX
- K LRHYMORD
- K LRHYMULT
- F LRI=-LRPAST:1:LRAHEAD D
- . S X1=DT S X2=LRI D C^%DTC S LR3DTN=X
- . ;
- . I $D(^LRO(69,LR3DTN,1,"AA",LRDFN)) D
- .. S LR3SN=0
- .. F S LR3SN=$O(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN)) Q:+LR3SN'>0 D
- ... ;
- ... Q:$P($G(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C" ;collected
- ... S LRTSTX=0
- ... F S LRTSTX=$O(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTSTX)) Q:+LRTSTX'>0 D
- .... S LRIENZZ=$O(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTSTX,0))
- .... ;
- .... Q:$G(^LRO(69,LR3DTN,1,LR3SN,2,LRIENZZ,1.1,1,0))'=""
- .... K LRCOL99 S LRCOL99=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
- .... S LRHYHOK=0 D CSE^LRHYA Q:LRHYHOK
- .... S LRCSTAT=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
- .... S LRHYHOK=0 D CSTATUS^LRHYA Q:LRHYHOK
- .... S LRLLOC66=$P(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
- .... S LRHYHOK=0 D EXLOC^LRHYA Q:LRHYHOK
- .... S LRHYMULT(LR3DTN,LR3SN,LRIENZZ)=LRTSTX
- N CNT
- S CNT=0
- S LR3DTN=0
- F S LR3DTN=$O(LRHYMULT(LR3DTN)) Q:+LR3DTN'>0 S CNT=CNT+1
- I CNT>1 S LRHYMORD=1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRHYB 6262 printed Mar 13, 2025@21:19:32 Page 2
- LRHYB ;DALOI/HOAK - HOWDY B DRIVER ;Sep 16, 2000
- +1 ;;5.2;LAB SERVICE;**405,417,446,457,467,491,573**;Sep 27, 1994;Build 7
- +2 ;
- TEST ;
- +1 SET DIC=2
- SET DIC(0)="AEMQZ"
- DO ^DIC
- +2 if Y=-1
- QUIT
- +3 SET LRDFN=$GET(^DPT(+Y,"LR"))
- +4 ;
- +5 ;
- +6 ;
- ORDCHK ; Here is where the search for an order number starts
- +1 KILL LRHYT654
- +2 ; The Howdy site file will help determine which orders the site
- +3 ; will accept. Once an order has been selected it is handed off
- +4 ; to LRORDST to start the accessioning process.
- +5 ;
- +6 NEW LRNAAAC
- +7 KILL LRWCZZZ,LRDTF
- +8 KILL LRHYCS33
- +9 KILL ^TMP("LRHYDY",$JOB,"KILL")
- +10 ;
- +11 ;
- +12 KILL ^TMP("LRHYDY",$JOB,"MULTD")
- +13 KILL ^TMP("LRHYDY",$JOB,"DUPTEST")
- +14 KILL LRHYCS
- +15 KILL ^TMP("LRHYDY",$JOB,"MT")
- +16 SET LRHOWDY=1
- +17 SET LREND=0
- +18 SET LRORD=""
- +19 if 'LRDFN
- QUIT
- +20 ;
- +21 KILL ^TMP("LRHYDY",$JOB,"LRSN"),LRNPZZX
- +22 SET LRHYOK=0
- +23 ;
- +24 ; 18 days ahead
- +25 ; 20 days back
- +26 ;
- +27 SET X2=0
- KILL LRNPZZX
- +28 SET LRAHEAD=$GET(^LRHY(69.86,LRHYSITE,18))
- +29 SET LRPAST=$GET(^LRHY(69.86,LRHYSITE,20))
- +30 KILL LRWCZZZ,LREXORD
- +31 ; flag for non-EXLOC and EXLOC on same specimen number
- SET LRLOCS=0
- +32 ;Search window set by site file.
- FOR LRI=-LRPAST:1:LRAHEAD
- Begin DoDot:1
- +33 SET X1=DT
- SET X2=LRI
- DO C^%DTC
- SET LR3DTN=X
- +34 IF $DATA(^LRO(69,LR3DTN,1,"AA",LRDFN))
- SET LRHYOK=1
- Begin DoDot:2
- +35 SET LR3SN=0
- +36 FOR
- SET LR3SN=$ORDER(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN))
- if +LR3SN'>0
- QUIT
- Begin DoDot:3
- +37 ;collected
- if $PIECE($GET(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C"
- QUIT
- +38 KILL LRWCZZZ
- +39 ;
- +40 KILL LRCOL99
- SET LRCOL99=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
- +41 KILL LRCSTAT
- SET LRCSTAT=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
- +42 ;Check collection status
- DO CSTATUS^LRHYA
- if LRHYHOK
- QUIT
- +43 ;
- +44 ;LR573 check for accession area conflict:
- +45 SET LRORD=^LRO(69,LR3DTN,1,LR3SN,.1)
- IF '$$Q18^LROE2(DUZ(2))
- SET (LRLAAX,LRHYHOK)=1
- +46 if LRHYHOK
- QUIT
- +47 ;
- +48 ;print order label tests
- DO OLT^LRHYA
- +49 if LRHYHOK
- QUIT
- +50 ;
- +51 ;
- +52 KILL LRNOTST
- +53 ;check for excluded lab tests
- SET LRNODUP=0
- DO LTE^LRHYA
- if LRHYHOK
- QUIT
- +54 ;
- +55 SET LRORD=^LRO(69,LR3DTN,1,LR3SN,.1)
- +56 SET LRLLOC66=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
- +57 ;check for locations to exclude
- DO EXLOC^LRHYA
- if LRHYHOK
- QUIT
- +58 ;
- +59 SET LRLLOC=$GET(LRLLOC66)
- +60 SET LRORD24=0
- +61 ;print order label tests
- DO OLT^LRHYA
- if LRHYHOK
- QUIT
- +62 ;
- +63 ;; CHECK URGENCY
- DO URG^LRHYA
- if LRHYHOK
- QUIT
- +64 KILL LRCOL99
- SET LRCOL99=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
- +65 ;check for excluded collection samples
- DO CSE^LRHYA
- if LRHYHOK
- QUIT
- +66 ;
- +67 IF $ORDER(^TMP("LRHYDY",$JOB,"EXLOC",LRORD,0))=$GET(LRLLOC66)
- IF $ORDER(^LRO(69,"C",LRORD,0))'=DT
- QUIT
- +68 ; CHECK URGENCY
- +69 ; micro test
- SET LRTST6=0
- +70 FOR
- SET LRTST6=$ORDER(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTST6))
- if +LRTST6'>0
- QUIT
- Begin DoDot:4
- +71 SET LRTSTZ99(LRTST6)=""
- +72 ; subscript
- IF LRTST6
- SET LRSUB1=$PIECE(^LAB(60,LRTST6,0),U,4)
- +73 if $DATA(LRNPZZX(^LRO(69,LR3DTN,1,LR3SN,.1),LR3SN,LRTST6))
- QUIT
- +74 SET LRORD=$GET(^LRO(69,LR3DTN,1,LR3SN,.1))
- +75 IF $GET(LRORD)
- IF $DATA(^TMP("LRHYDY",$JOB,"STATUS",LRORD))
- QUIT
- +76 IF $DATA(LRNOTST)
- IF $DATA(LRNOTST(LRTST6))
- KILL LRORD
- QUIT
- +77 SET ^TMP("LRHYDY",$JOB,"LRSN",LR3DTN,^LRO(69,LR3DTN,1,LR3SN,.1))=""
- +78 SET LRDTX=""
- +79 SET LRDTX=$ORDER(^LRO(69,"C",^LRO(69,LR3DTN,1,LR3SN,.1),0))
- +80 IF $DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
- IF LR3DTN=DT
- IF $GET(LRDTX)
- SET ^TMP("LRHYDY",$JOB,"MT",LRDTX)=""
- +81 IF '$DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
- IF $GET(LRDTX)
- SET ^TMP("LRHYDY",$JOB,"MT",LRDTX)=""
- End DoDot:4
- End DoDot:3
- if $GET(LRLOCS)
- QUIT
- End DoDot:2
- End DoDot:1
- if $GET(LRLOCS)
- QUIT
- +82 ;
- +83 ;
- +84 KILL LRMULT
- +85 IF $GET(LRWCMULT)
- WRITE !!!!,"Multple Orders Present"
- SET LRMULT=1
- DO LOG1^LRHY0
- KILL LRWCMULT
- QUIT
- +86 ; per Libba 1/14/2002
- +87 ; I prefer today's orders but...
- IF $DATA(^TMP("LRHYDY",$JOB,"LRSN",DT))
- SET LR3DTN=DT
- +88 ; I'll take whatever ya got
- IF '$TEST
- SET LR3DTN=$ORDER(^TMP("LRHYDY",$JOB,"LRSN",0))
- +89 IF 'LR3DTN
- KILL LRORD
- QUIT
- +90 ;
- +91 IF '$DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
- IF $ORDER(^TMP("LRHYDY",$JOB,"LRSN",LR3DTN))
- WRITE !,"MULTIPLE DAYS WITH ORDERS"
- SET LRMULT=1
- DO LOG1^LRHY0
- QUIT
- +92 ;
- +93 SET LRTIC=0
- +94 SET LRMULT=0
- +95 ;
- +96 FOR
- SET LRTIC=$ORDER(^TMP("LRHYDY",$JOB,"LRSN",LRTIC))
- if +LRTIC'>0
- QUIT
- SET LRMULT=LRMULT+1
- +97 IF '$DATA(^LRHY(69.86,LRHYSITE,16,"B",LRLLOC66))
- IF LRMULT>1
- WRITE !,"MULTIPLE DAYS WITH ORDERS"
- SET LRMULT=0
- DO LOG1^LRHY0
- QUIT
- +98 ;MODIFIED BY HOAK to flag when wc and sp are on same visit
- +99 ;
- +100 ;
- MOVE ;
- +1 IF $DATA(LRNOTST)
- IF $GET(LRHYT654)
- IF $DATA(LRNOTST(LRHYT654))
- KILL LRORD
- QUIT
- +2 IF $GET(LRORD)
- IF $DATA(LREXORD(LRORD))
- KILL LRORD
- QUIT
- +3 SET LRHY3SN3=0
- +4 SET LRHY3DT3=0
- +5 IF $GET(LRORD)
- IF $DATA(^TMP("LRHYDY",$JOB,"URG",LRORD))
- KILL LRORD
- QUIT
- +6 IF $DATA(^LRHY(69.86,LRHYSITE,30,"B",LRURGZ19))
- KILL LRORD
- QUIT
- +7 SET LRTIC=0
- +8 SET LRMULT=0
- +9 FOR
- SET LRTIC=$ORDER(^TMP("LRHYDY",$JOB,"MT",LRTIC))
- if +LRTIC'>0
- QUIT
- SET LRMULT=LRMULT+1
- +10 SET LR3MULT=LRMULT
- +11 IF LRMULT>1
- WRITE !,"MULTIPLE DAYS WITH ORDERS"
- SET LRORD=0
- QUIT
- +12 IF '$TEST
- SET LRMULT=0
- +13 ; may be accessioned.
- +14 ; Setting up task to continue based on the specimen.
- +15 KILL LR3ZTST
- MOVE1 ;
- +1 SET LRORD=0
- +2 FOR
- SET LRORD=$ORDER(^TMP("LRHYDY",$JOB,"LRSN",LR3DTN,LRORD))
- if +LRORD'>0
- QUIT
- Begin DoDot:1
- +3 if '$GET(LR3ORD)
- SET LR3ORD=LRORD
- +4 IF $DATA(^TMP("LRHYDY",$JOB,"URG",LRORD))
- QUIT
- +5 SET LRHYORDZ=LRORD
- +6 ;
- +7 SET ZTSAVE("^TMP(""LRHYDY"",$J,")=""
- +8 SET ZTRTN="PAST^LRHYPH0"
- SET ZTSAVE("L*")=""
- SET ZTDTH=$HOROLOG
- SET ZTDESC="HOWDY"
- +9 SET ZTIO="NULL"
- +10 SET ZTSAVE("L*")=""
- +11 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- DO ^%ZTLOAD
- +12 SET LRGOTIT=1
- +13 SET LRORD=LRHYORDZ
- +14 KILL LRSTOPZ(LRORD)
- End DoDot:1
- +15 KILL ^TMP("LRHYDY",$JOB,"MULTD")
- +16 SET LRORD=$GET(LR3ORD)
- KILL LR3ORD
- +17 KILL LRHOWDY,LR3SN24,LR3DTN24,LR3ZTST,LROLT1,LRNAAAC
- +18 IF $GET(LRORD)
- IF $DATA(LRSTOPZ(LRORD))
- KILL LRORD,LRSTOPZ
- QUIT
- +19 ;
- +20 QUIT
- +21 ;
- MMM ;
- +1 NEW LRI
- SET LRI=0
- +2 NEW LR3DTN,LR3SN,LRIENZZ,LRTSTX
- +3 KILL LRHYMORD
- +4 KILL LRHYMULT
- +5 FOR LRI=-LRPAST:1:LRAHEAD
- Begin DoDot:1
- +6 SET X1=DT
- SET X2=LRI
- DO C^%DTC
- SET LR3DTN=X
- +7 ;
- +8 IF $DATA(^LRO(69,LR3DTN,1,"AA",LRDFN))
- Begin DoDot:2
- +9 SET LR3SN=0
- +10 FOR
- SET LR3SN=$ORDER(^LRO(69,LR3DTN,1,"AA",LRDFN,LR3SN))
- if +LR3SN'>0
- QUIT
- Begin DoDot:3
- +11 ;
- +12 ;collected
- if $PIECE($GET(^LRO(69,LR3DTN,1,LR3SN,1)),U,4)="C"
- QUIT
- +13 SET LRTSTX=0
- +14 FOR
- SET LRTSTX=$ORDER(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTSTX))
- if +LRTSTX'>0
- QUIT
- Begin DoDot:4
- +15 SET LRIENZZ=$ORDER(^LRO(69,LR3DTN,1,LR3SN,2,"B",LRTSTX,0))
- +16 ;
- +17 if $GET(^LRO(69,LR3DTN,1,LR3SN,2,LRIENZZ,1.1,1,0))'=""
- QUIT
- +18 KILL LRCOL99
- SET LRCOL99=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,3)
- +19 SET LRHYHOK=0
- DO CSE^LRHYA
- if LRHYHOK
- QUIT
- +20 SET LRCSTAT=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,4)
- +21 SET LRHYHOK=0
- DO CSTATUS^LRHYA
- if LRHYHOK
- QUIT
- +22 SET LRLLOC66=$PIECE(^LRO(69,LR3DTN,1,LR3SN,0),U,9)
- +23 SET LRHYHOK=0
- DO EXLOC^LRHYA
- if LRHYHOK
- QUIT
- +24 SET LRHYMULT(LR3DTN,LR3SN,LRIENZZ)=LRTSTX
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +25 NEW CNT
- +26 SET CNT=0
- +27 SET LR3DTN=0
- +28 FOR
- SET LR3DTN=$ORDER(LRHYMULT(LR3DTN))
- if +LR3DTN'>0
- QUIT
- SET CNT=CNT+1
- +29 IF CNT>1
- SET LRHYMORD=1
