- LRORDB ;VA/DALOI/FHS - ORDER LEDI TEST USING BARCODE FROM 69.6 ;JUL 06, 2010 3:14 PM
- ;;5.2;LAB SERVICE;**153,222,286,1027**;NOV 01, 1997
- ;
- EN(LRRUID,LRSSMP) ;
- ;
- N I,LRSTATUS,LRX
- ;
- K LROT
- ;
- S (LROT,LRSTATUS)=""
- ;
- Q:'$L($G(LRRUID))!('$L($G(LRSSMP)))
- S LR696=$O(^LRO(69.6,"AD",LRSSMP,LRRUID,0)) Q:'LR696
- Q:'$D(^LRO(69.6,LR696,0))#2
- ;
- S LRX=+$P(^LRO(69.6,LR696,0),U,10)
- I LRX S LRSTATUS=$$GET1^DIQ(64.061,LRX_",",.01)
- I LRSTATUS'="",LRSTATUS'="In-Transit" D
- . S I=0
- . F S I=$O(^LRO(69.6,LR696,2,I)) Q:'I D Q:LRSTATUS="In-Transit"
- . . S X=$P(^LRO(69.6,LR696,2,I,0),"^",6) Q:'X
- . . I $$GET1^DIQ(64.061,X_",",.01)="In-Transit" S LRSTATUS="In-Transit"
- ;
- I LRSTATUS'="",LRSTATUS'="In-Transit" D Q
- . N DIR
- . S DIR("A",1)="This order has a status of [ "_LRSTATUS_" ]"
- . S DIR("A",2)="No test selected."
- . D DISPLO
- ;
- ; Display any comments that accompanied order
- I $D(^LRO(69.6,LR696,99)) D
- . N LRWP
- . S LRWP=$$GET1^DIQ(69.6,LR696_",",99,"","LRWP")
- . S LRWP(.5)="Collecting site order comments:",LRWP(.5,"F")="!!"
- . D EN^DDIOL(.LRWP)
- ;
- D LROT(LR696)
- ;
- I $O(LROT(0)) D LL3^LROW3
- I '$O(LROT(0)) D Q
- . N DIR
- . S DIR("A",1)="NO tests found on Shipping Manifest "_$G(LRRSITE("SMID"))
- . S DIR("A",2)="For UID "_$G(LRRUID)
- . D DISPLO
- ;
- S $P(^LRO(69.6,LR696,0),U,11)=$G(LRSD("RIEN"))
- Q
- ;
- ;
- LROT(LR696) ;
- ;
- N LR60,LR6205,LR6964,LRATG,LRMICHK,LRNLT,LRX,LRY,X
- ;
- K LROT
- ;
- S LR696(0)=$G(^LRO(69.6,LR696,0))
- S LRSPEC=+$P(LR696(0),U,7),LRSAMP=+$P(LR696(0),U,8)
- ;Q:'LRSPEC!('$D(^LAB(61,LRSPEC,0)))
- S (LR6964,LRMICHK)=0
- F S LR6964=+$O(^LRO(69.6,LR696,2,LR6964)) Q:LR6964<1 D
- . S LR6964(0)=$G(^LRO(69.6,LR696,2,LR6964,0))
- . I LR6964(0)="" Q
- . I $P(LR6964(0),"^",6),$$GET1^DIQ(64.061,$P(LR6964(0),"^",6)_",",.01)'="In-Transit" Q
- . S LR60=$P(LR6964(0),U,11) ; Lab test to order
- . S LR6205=$P(LR6964(0),U,12) ; Urgency
- . I 'LRMICHK,LR60>0,$P(^LAB(60,LR60,0),U,4)="MI" D MICHECK
- . S LRATG=0
- . ; If have everything, then don't check accession test group.
- . I LR60,LRSPEC,LRSAMP,LR6205 D Q:LRATG
- . . S LR64=+$G(^LAB(60,LR60,64))
- . . I 'LR64 Q
- . . S LRNLT=$P($G(^LAM(LR64,0)),U,2),LRNLT(2)=$P($G(^LAM(LR64,0)),U)
- . . ; Find available spot.
- . . F LRATG=LRWPC+1:1 I '$D(LROT(LRSAMP,LRSPEC,LRATG)) S LRWPC=LRATG Q
- . . D CHKURG,SETLROT
- . S LRNLT=$P(LR6964(0),U,2) Q:'LRNLT
- . S LRNLT(1)=+$O(^LAM("C",LRNLT_" ",0))
- . I 'LRNLT(1)!('$D(^LAM(LRNLT(1),0))) Q
- . S LRNLT(2)=$P(^LAM(LRNLT(1),0),U),LR60=0
- . F S LR60=+$O(^LAB(60,"AC",LRNLT(1),LR60)) Q:'LR60 D
- . . S LRATG=+$O(^TMP("LRSTIK",$J,"C",LR60,0)) Q:LRATG<1
- . . S LRATG(1)=$G(^TMP("LRSTIK",$J,LRATG)) Q:'LRATG(1)!('$P(LRATG(1),U,3))
- . . S:'$G(LRSAMP) LRSAMP=$P(LRATG(1),U,3)
- . . D CHKURG
- . . I LR60,LRSPEC,LRSAMP,LR6205 D SETLROT
- Q
- ;
- ;
- SETLROT ; Setup LROT array
- ;
- S LROT(LRSAMP,LRSPEC,LRATG)=LR60
- S LROT(LRSAMP,LRSPEC,LRATG,1)=LR6205
- S LROT(LRSAMP,LRSPEC,LRATG,"B",LR60)=LR6964_U_LRNLT_U_LRNLT(2)
- ;
- ; Required comment
- S:$P($G(^LAB(60,LR60,0)),U,19) LROT(LRSAMP,LRSPEC,LRATG,2)=$P(^(0),U,19)
- ;
- Q
- ;
- ;
- CHKURG ; Check for forced, highest allowed and missing urgency on this test
- ;
- N X
- ;
- ; Forced urgency
- I +$P(^LAB(60,LR60,0),U,18) S LR6205=+$P(^LAB(60,LR60,0),U,18)
- ;
- ; If missing urgency then look above workload urgencies for last urgency
- ; that matches on HL7 urgency othewise use site's default for routine.
- I 'LR6205 D
- . S X=$P(LR6964(0),U,5)
- . I $L(X) S LR6205=+$O(^LAB(62.05,"HL7",X,50),-1)
- . S LR6205=$S(LR6205>0:LR6205,1:LROUTINE)
- ;
- ; Highest urgency allowed, reset if higher than highest allowed.
- S X=+$P(^LAB(60,LR60,0),U,16)
- I LR6205<X S LR6205=X
- ;
- Q
- ;
- ;
- MICHECK ; Check "MI" subscript test for missing topography and collection sample
- ;
- N DA,DIE,DR,X,Y
- S DA=LR696,DIE=69.6,DR="",LRMICHK=1
- I LRSPEC'>0 S DR=4_";"
- I LRSAMP'>0 S DR=DR_5
- I LRSPEC D
- . S LRX=$$GET1^DIQ(61,LRSPEC_",",".09:2")
- . I LRX="XXX"!(LRX="ORH") S DR="4;5"
- I DR="" Q
- D EN^DDIOL("Update missing order information for:",,"!!")
- D EN^DDIOL("",,"!")
- D ^DIE
- S LR696(0)=$G(^LRO(69.6,LR696,0))
- S LRSPEC=+$P(LR696(0),U,7),LRSAMP=+$P(LR696(0),U,8)
- ;
- Q
- ;
- ;
- SMID ; Call to get shipping manifest ID (manual selection)
- N CNT,DA,DIR,LRSMID,LRY,X,Y
- S LREND=0,LRSMID=""
- S DIR(0)="69.6,18" D ^DIR
- I $D(DTOUT)!($D(DUOUT)) S LREND=1 Q
- I $D(DIRUT) Q
- S LRY=Y
- I LRY'="",$D(^LRO(69.6,"D",LRY)) S LRSMID=LRY
- I LRSMID="" D
- . D SHOW
- . K ^TMP("LR",$J,"SMID")
- ;
- I LRSMID="" D Q
- . N DIR
- . S DIR(0)="YO",DIR("A")="Use manifest '"_LRY_"' anyway",DIR("B")="NO"
- . W ! D ^DIR
- . I Y S LRRSITE("SMID")=LRY
- ;
- S LRRSITE("SMID")=LRSMID
- S LRY=$O(^LRO(69.6,"D",LRSMID,0))
- I LRY S LRRSITE("SDT")=$$GET1^DIQ(69.6,LRY_",",14,"I")
- K DIR
- ;
- ; Flag to determine if this shipping manfiest should be used to
- ; look up orders when manually accessioning.
- S DIR(0)="YO",DIR("A")="Lookup orders using this manifest",DIR("B")="YES"
- D ^DIR
- I $D(DIRUT) S LREND=1 Q
- S LRRSITE("SMID-OK")=Y
- Q
- ;
- ;
- SHOW ; Gather a list of possible SMID to select from
- N CNT,DIR,IEN,LEN,SMID,VAL
- K ^TMP("LR",$J,"SMID")
- S SMID=LRY,LEN=$L(LRY),CNT=0
- I SMID?1.N S SMID=SMID_" "
- F S SMID=$O(^LRO(69.6,"D",SMID)) Q:$E(SMID,1,LEN)'=LRY D
- . S IEN=+$O(^LRO(69.6,"D",SMID,0))
- . I $P($G(^LRO(69.6,IEN,0)),"^",5)'=+$G(LRRSITE("RSITE")) Q
- . S CNT=CNT+1
- . S ^TMP("LR",$J,"SMID",CNT)=SMID
- I 'CNT W !,"No manifest '",LRY,"' found on file." Q
- I CNT=1 S LRSMID=^TMP("LR",$J,"SMID",CNT) Q
- ;
- ; Select SMID from List
- D DISPL
- S DIR(0)="NO^1:"_CNT,DIR("A")="Select Manifest Number"
- D ^DIR
- I $D(DIRUT) W !,"No manifest selected." Q
- S LRSMID=$G(^TMP("LR",$J,"SMID",Y))
- Q
- ;
- ;
- DISPL ;
- N CNT,DIR,DIRUT
- W @IOF
- S CNT=0
- F S CNT=$O(^TMP("LR",$J,"SMID",CNT)) Q:'CNT D Q:$D(DIRUT)
- . I CNT#3=1 D Q:$D(DIRUT)
- . . I '(CNT#(IOSL-3)) S DIR(0)="E" D ^DIR Q:$D(DIRUT)
- . . W !
- . W $$LJ^XLFSTR(CNT_". "_^TMP("LR",$J,"SMID",CNT),26)
- Q
- ;
- ;
- DISPLO ; Display the order from #69.6
- N DA,DIC,DIRUT,DTOUT,DUOUT,DX,S,X,Y
- S DIR("A")="Would you like a display of the Order"
- S DIR(0)="Y" D ^DIR K DIR
- I $D(DIROUT)!(Y'=1) W ! Q
- S DA=LR696,DIC="^LRO(69.6,",S=0 W @IOF D EN^DIQ W !
- Q
- LRORDB ;VA/DALOI/FHS - ORDER LEDI TEST USING BARCODE FROM 69.6 ;JUL 06, 2010 3:14 PM
- +1 ;;5.2;LAB SERVICE;**153,222,286,1027**;NOV 01, 1997
- +2 ;
- EN(LRRUID,LRSSMP) ;
- +1 ;
- +2 NEW I,LRSTATUS,LRX
- +3 ;
- +4 KILL LROT
- +5 ;
- +6 SET (LROT,LRSTATUS)=""
- +7 ;
- +8 IF '$LENGTH($GET(LRRUID))!('$LENGTH($GET(LRSSMP)))
- QUIT
- +9 SET LR696=$ORDER(^LRO(69.6,"AD",LRSSMP,LRRUID,0))
- IF 'LR696
- QUIT
- +10 IF '$DATA(^LRO(69.6,LR696,0))#2
- QUIT
- +11 ;
- +12 SET LRX=+$PIECE(^LRO(69.6,LR696,0),U,10)
- +13 IF LRX
- SET LRSTATUS=$$GET1^DIQ(64.061,LRX_",",.01)
- +14 IF LRSTATUS'=""
- IF LRSTATUS'="In-Transit"
- Begin DoDot:1
- +15 SET I=0
- +16 FOR
- SET I=$ORDER(^LRO(69.6,LR696,2,I))
- IF 'I
- QUIT
- Begin DoDot:2
- +17 SET X=$PIECE(^LRO(69.6,LR696,2,I,0),"^",6)
- IF 'X
- QUIT
- +18 IF $$GET1^DIQ(64.061,X_",",.01)="In-Transit"
- SET LRSTATUS="In-Transit"
- End DoDot:2
- IF LRSTATUS="In-Transit"
- QUIT
- End DoDot:1
- +19 ;
- +20 IF LRSTATUS'=""
- IF LRSTATUS'="In-Transit"
- Begin DoDot:1
- +21 NEW DIR
- +22 SET DIR("A",1)="This order has a status of [ "_LRSTATUS_" ]"
- +23 SET DIR("A",2)="No test selected."
- +24 DO DISPLO
- End DoDot:1
- QUIT
- +25 ;
- +26 ; Display any comments that accompanied order
- +27 IF $DATA(^LRO(69.6,LR696,99))
- Begin DoDot:1
- +28 NEW LRWP
- +29 SET LRWP=$$GET1^DIQ(69.6,LR696_",",99,"","LRWP")
- +30 SET LRWP(.5)="Collecting site order comments:"
- SET LRWP(.5,"F")="!!"
- +31 DO EN^DDIOL(.LRWP)
- End DoDot:1
- +32 ;
- +33 DO LROT(LR696)
- +34 ;
- +35 IF $ORDER(LROT(0))
- DO LL3^LROW3
- +36 IF '$ORDER(LROT(0))
- Begin DoDot:1
- +37 NEW DIR
- +38 SET DIR("A",1)="NO tests found on Shipping Manifest "_$GET(LRRSITE("SMID"))
- +39 SET DIR("A",2)="For UID "_$GET(LRRUID)
- +40 DO DISPLO
- End DoDot:1
- QUIT
- +41 ;
- +42 SET $PIECE(^LRO(69.6,LR696,0),U,11)=$GET(LRSD("RIEN"))
- +43 QUIT
- +44 ;
- +45 ;
- LROT(LR696) ;
- +1 ;
- +2 NEW LR60,LR6205,LR6964,LRATG,LRMICHK,LRNLT,LRX,LRY,X
- +3 ;
- +4 KILL LROT
- +5 ;
- +6 SET LR696(0)=$GET(^LRO(69.6,LR696,0))
- +7 SET LRSPEC=+$PIECE(LR696(0),U,7)
- SET LRSAMP=+$PIECE(LR696(0),U,8)
- +8 ;Q:'LRSPEC!('$D(^LAB(61,LRSPEC,0)))
- +9 SET (LR6964,LRMICHK)=0
- +10 FOR
- SET LR6964=+$ORDER(^LRO(69.6,LR696,2,LR6964))
- IF LR6964<1
- QUIT
- Begin DoDot:1
- +11 SET LR6964(0)=$GET(^LRO(69.6,LR696,2,LR6964,0))
- +12 IF LR6964(0)=""
- QUIT
- +13 IF $PIECE(LR6964(0),"^",6)
- IF $$GET1^DIQ(64.061,$PIECE(LR6964(0),"^",6)_",",.01)'="In-Transit"
- QUIT
- +14 ; Lab test to order
- SET LR60=$PIECE(LR6964(0),U,11)
- +15 ; Urgency
- SET LR6205=$PIECE(LR6964(0),U,12)
- +16 IF 'LRMICHK
- IF LR60>0
- IF $PIECE(^LAB(60,LR60,0),U,4)="MI"
- DO MICHECK
- +17 SET LRATG=0
- +18 ; If have everything, then don't check accession test group.
- +19 IF LR60
- IF LRSPEC
- IF LRSAMP
- IF LR6205
- Begin DoDot:2
- +20 SET LR64=+$GET(^LAB(60,LR60,64))
- +21 IF 'LR64
- QUIT
- +22 SET LRNLT=$PIECE($GET(^LAM(LR64,0)),U,2)
- SET LRNLT(2)=$PIECE($GET(^LAM(LR64,0)),U)
- +23 ; Find available spot.
- +24 FOR LRATG=LRWPC+1:1
- IF '$DATA(LROT(LRSAMP,LRSPEC,LRATG))
- SET LRWPC=LRATG
- QUIT
- +25 DO CHKURG
- DO SETLROT
- End DoDot:2
- IF LRATG
- QUIT
- +26 SET LRNLT=$PIECE(LR6964(0),U,2)
- IF 'LRNLT
- QUIT
- +27 SET LRNLT(1)=+$ORDER(^LAM("C",LRNLT_" ",0))
- +28 IF 'LRNLT(1)!('$DATA(^LAM(LRNLT(1),0)))
- QUIT
- +29 SET LRNLT(2)=$PIECE(^LAM(LRNLT(1),0),U)
- SET LR60=0
- +30 FOR
- SET LR60=+$ORDER(^LAB(60,"AC",LRNLT(1),LR60))
- IF 'LR60
- QUIT
- Begin DoDot:2
- +31 SET LRATG=+$ORDER(^TMP("LRSTIK",$JOB,"C",LR60,0))
- IF LRATG<1
- QUIT
- +32 SET LRATG(1)=$GET(^TMP("LRSTIK",$JOB,LRATG))
- IF 'LRATG(1)!('$PIECE(LRATG(1),U,3))
- QUIT
- +33 IF '$GET(LRSAMP)
- SET LRSAMP=$PIECE(LRATG(1),U,3)
- +34 DO CHKURG
- +35 IF LR60
- IF LRSPEC
- IF LRSAMP
- IF LR6205
- DO SETLROT
- End DoDot:2
- End DoDot:1
- +36 QUIT
- +37 ;
- +38 ;
- SETLROT ; Setup LROT array
- +1 ;
- +2 SET LROT(LRSAMP,LRSPEC,LRATG)=LR60
- +3 SET LROT(LRSAMP,LRSPEC,LRATG,1)=LR6205
- +4 SET LROT(LRSAMP,LRSPEC,LRATG,"B",LR60)=LR6964_U_LRNLT_U_LRNLT(2)
- +5 ;
- +6 ; Required comment
- +7 IF $PIECE($GET(^LAB(60,LR60,0)),U,19)
- SET LROT(LRSAMP,LRSPEC,LRATG,2)=$PIECE(^(0),U,19)
- +8 ;
- +9 QUIT
- +10 ;
- +11 ;
- CHKURG ; Check for forced, highest allowed and missing urgency on this test
- +1 ;
- +2 NEW X
- +3 ;
- +4 ; Forced urgency
- +5 IF +$PIECE(^LAB(60,LR60,0),U,18)
- SET LR6205=+$PIECE(^LAB(60,LR60,0),U,18)
- +6 ;
- +7 ; If missing urgency then look above workload urgencies for last urgency
- +8 ; that matches on HL7 urgency othewise use site's default for routine.
- +9 IF 'LR6205
- Begin DoDot:1
- +10 SET X=$PIECE(LR6964(0),U,5)
- +11 IF $LENGTH(X)
- SET LR6205=+$ORDER(^LAB(62.05,"HL7",X,50),-1)
- +12 SET LR6205=$SELECT(LR6205>0:LR6205,1:LROUTINE)
- End DoDot:1
- +13 ;
- +14 ; Highest urgency allowed, reset if higher than highest allowed.
- +15 SET X=+$PIECE(^LAB(60,LR60,0),U,16)
- +16 IF LR6205<X
- SET LR6205=X
- +17 ;
- +18 QUIT
- +19 ;
- +20 ;
- MICHECK ; Check "MI" subscript test for missing topography and collection sample
- +1 ;
- +2 NEW DA,DIE,DR,X,Y
- +3 SET DA=LR696
- SET DIE=69.6
- SET DR=""
- SET LRMICHK=1
- +4 IF LRSPEC'>0
- SET DR=4_";"
- +5 IF LRSAMP'>0
- SET DR=DR_5
- +6 IF LRSPEC
- Begin DoDot:1
- +7 SET LRX=$$GET1^DIQ(61,LRSPEC_",",".09:2")
- +8 IF LRX="XXX"!(LRX="ORH")
- SET DR="4;5"
- End DoDot:1
- +9 IF DR=""
- QUIT
- +10 DO EN^DDIOL("Update missing order information for:",,"!!")
- +11 DO EN^DDIOL("",,"!")
- +12 DO ^DIE
- +13 SET LR696(0)=$GET(^LRO(69.6,LR696,0))
- +14 SET LRSPEC=+$PIECE(LR696(0),U,7)
- SET LRSAMP=+$PIECE(LR696(0),U,8)
- +15 ;
- +16 QUIT
- +17 ;
- +18 ;
- SMID ; Call to get shipping manifest ID (manual selection)
- +1 NEW CNT,DA,DIR,LRSMID,LRY,X,Y
- +2 SET LREND=0
- SET LRSMID=""
- +3 SET DIR(0)="69.6,18"
- DO ^DIR
- +4 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET LREND=1
- QUIT
- +5 IF $DATA(DIRUT)
- QUIT
- +6 SET LRY=Y
- +7 IF LRY'=""
- IF $DATA(^LRO(69.6,"D",LRY))
- SET LRSMID=LRY
- +8 IF LRSMID=""
- Begin DoDot:1
- +9 DO SHOW
- +10 KILL ^TMP("LR",$JOB,"SMID")
- End DoDot:1
- +11 ;
- +12 IF LRSMID=""
- Begin DoDot:1
- +13 NEW DIR
- +14 SET DIR(0)="YO"
- SET DIR("A")="Use manifest '"_LRY_"' anyway"
- SET DIR("B")="NO"
- +15 WRITE !
- DO ^DIR
- +16 IF Y
- SET LRRSITE("SMID")=LRY
- End DoDot:1
- QUIT
- +17 ;
- +18 SET LRRSITE("SMID")=LRSMID
- +19 SET LRY=$ORDER(^LRO(69.6,"D",LRSMID,0))
- +20 IF LRY
- SET LRRSITE("SDT")=$$GET1^DIQ(69.6,LRY_",",14,"I")
- +21 KILL DIR
- +22 ;
- +23 ; Flag to determine if this shipping manfiest should be used to
- +24 ; look up orders when manually accessioning.
- +25 SET DIR(0)="YO"
- SET DIR("A")="Lookup orders using this manifest"
- SET DIR("B")="YES"
- +26 DO ^DIR
- +27 IF $DATA(DIRUT)
- SET LREND=1
- QUIT
- +28 SET LRRSITE("SMID-OK")=Y
- +29 QUIT
- +30 ;
- +31 ;
- SHOW ; Gather a list of possible SMID to select from
- +1 NEW CNT,DIR,IEN,LEN,SMID,VAL
- +2 KILL ^TMP("LR",$JOB,"SMID")
- +3 SET SMID=LRY
- SET LEN=$LENGTH(LRY)
- SET CNT=0
- +4 IF SMID?1.N
- SET SMID=SMID_" "
- +5 FOR
- SET SMID=$ORDER(^LRO(69.6,"D",SMID))
- IF $EXTRACT(SMID,1,LEN)'=LRY
- QUIT
- Begin DoDot:1
- +6 SET IEN=+$ORDER(^LRO(69.6,"D",SMID,0))
- +7 IF $PIECE($GET(^LRO(69.6,IEN,0)),"^",5)'=+$GET(LRRSITE("RSITE"))
- QUIT
- +8 SET CNT=CNT+1
- +9 SET ^TMP("LR",$JOB,"SMID",CNT)=SMID
- End DoDot:1
- +10 IF 'CNT
- WRITE !,"No manifest '",LRY,"' found on file."
- QUIT
- +11 IF CNT=1
- SET LRSMID=^TMP("LR",$JOB,"SMID",CNT)
- QUIT
- +12 ;
- +13 ; Select SMID from List
- +14 DO DISPL
- +15 SET DIR(0)="NO^1:"_CNT
- SET DIR("A")="Select Manifest Number"
- +16 DO ^DIR
- +17 IF $DATA(DIRUT)
- WRITE !,"No manifest selected."
- QUIT
- +18 SET LRSMID=$GET(^TMP("LR",$JOB,"SMID",Y))
- +19 QUIT
- +20 ;
- +21 ;
- DISPL ;
- +1 NEW CNT,DIR,DIRUT
- +2 WRITE @IOF
- +3 SET CNT=0
- +4 FOR
- SET CNT=$ORDER(^TMP("LR",$JOB,"SMID",CNT))
- IF 'CNT
- QUIT
- Begin DoDot:1
- +5 IF CNT#3=1
- Begin DoDot:2
- +6 IF '(CNT#(IOSL-3))
- SET DIR(0)="E"
- DO ^DIR
- IF $DATA(DIRUT)
- QUIT
- +7 WRITE !
- End DoDot:2
- IF $DATA(DIRUT)
- QUIT
- +8 WRITE $$LJ^XLFSTR(CNT_". "_^TMP("LR",$JOB,"SMID",CNT),26)
- End DoDot:1
- IF $DATA(DIRUT)
- QUIT
- +9 QUIT
- +10 ;
- +11 ;
- DISPLO ; Display the order from #69.6
- +1 NEW DA,DIC,DIRUT,DTOUT,DUOUT,DX,S,X,Y
- +2 SET DIR("A")="Would you like a display of the Order"
- +3 SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- +4 IF $DATA(DIROUT)!(Y'=1)
- WRITE !
- QUIT
- +5 SET DA=LR696
- SET DIC="^LRO(69.6,"
- SET S=0
- WRITE @IOF
- DO EN^DIQ
- WRITE !
- +6 QUIT