LRWLST11.m

LRWLST11 ;DALOI/CJS,RWF/FHS - ACCESSION SETUP ; 01-May-2015 06:30 ; MKK

 ;;5.2;LAB SERVICE;**121,128,153,202,1018,286,1027,331,375,1031,1034,1035**;NOV 01, 1997;Build 5

 ;

 ;

ST21 ;

 S LRTS="",LRIX=0

 F  S LRIX=$O(LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)) Q:LRIX<1  D SET Q:LRUNQ

 ;

 S LRNT=$$NOW^XLFDT

 D SCDT,SLRSS

 ;

COMMON ; Setup 'in common' accession if not already setup unless it will be 

 ; when tests are acessioned to the 'in common' area.

 I +LRWLC,+LRWLC'=+LRAA,$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$G(LRDFN) D

 . I 'LRUNQ,$D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q

 . Q:$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1))

 . N LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y

 . S (LRQUIET,LRCOMMON)=1,LRAA=+LRWLC,LRORDRR=""

 . S X=LRSS,LRCDTX=LRCDT

 . N LRCDT,LRSS

 . S LRCDT=LRCDTX,LRSS=X_U_(1+$G(LRLBLBP))

 . D STWLN^LRWLST1 Q:$G(LREND)

 . D ST2^LRWLST1 Q:$G(LREND)

 . D SCDT,SLRSS

 ;

 Q

 ;

 ;

SCDT ; Set collection, inverse and lab arrival date/times on accession

 N FDA,LR6802,LRDIE

 S LR6802=LRAN_","_LRAD_","_LRAA_","

 S FDA(4,68.02,LR6802,9)=LRCDT

 S FDA(4,68.02,LR6802,10)=LREAL

 I '$D(LRPHSET) S FDA(4,68.02,LR6802,12)=LRNT

 S FDA(4,68.02,LR6802,13.5)=LRIDT

 D FILE^DIE("","FDA(4)","LRDIE(4)")

 ; I $D(LRDIE(4)) D MAILALRT^LRWLST1

 I $D(LRDIE(4)) D MAILALRT^LRWLST1("7 SCDT")          ; IHS/MSC/MKK - LR*5.2*1031

 Q

 ;

 ;

SLRSS ;

 ;

 S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) ; change for AP

 S H8=$S($D(LRSPEC):LRSPEC,1:X)_U_$S("CYEMSPAU"[LRSS:LRACC,1:LRACC)_U_$S(LRSS="MI":LRPRAC,1:"")_U_$S(LRSS="MI":LRLLOC,1:"")_"^^"_$S(LRSS="CH":LRPRAC,1:"")_"^"_$S(LRSS="MI":$P(LRSAMP,";",1),LRSS="CH":LRLLOC,1:"")

 ;

 I $S(LRSS="CH":1,LRSS="MI":1,1:0) D

 . I $G(LRORDRR)="R",+$G(LRRSITE("RSITE")) S $P(H8,U,9)=+LRRSITE("RSITE")_";DIC(4,"

 . I $G(LROLLOC),$G(LRORDRR)'="R" S $P(H8,U,9)=LROLLOC_";SC("

 . S $P(H8,U,10)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))

 ;

 S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8

 I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3

 ;

ST3 D ST4:(LRSS="MI"),LRCCOM

 ;

 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPR=1

 S LRRB=0

 I LRDPF=2 S LRRB=$$GET1^DIQ(2,DFN_",",.101),LRRB=$S(LRRB'="":LRRB,1:0)

 ;

 Q:$G(LRORDR)="P"

 ;

 I '$D(LRTJ) D  Q

 . I $G(LRORDRR)="R",LRSS="CH",$G(LRORU3)'="",$P(LRORU3,"^")'=$P(LRORU3,"^",4) Q  ; Don't print, use label from sending facility.

 . I LRLBLBP,'$G(LRCOMMON) S LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$S($D(LRORD):LRORD,1:"")

 S I=0

 F  S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5  S LRTS=^(I,0) D Z

 Q

 ;

 ;

ST4 ;

 S $P(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$S($D(LRNT):LRNT,1:""),$P(^(0),U,8)=LRLLOC

 ; Used to be LRSPCDSC,63.05,.9 (Word Processing field) replaces 63.05,.99

 S:$D(LRCCOM) ^LR(LRDFN,LRSS,LRIDT,99)=LRCCOM

 I '$D(LRPHSET) D

 . N DA,DIE,DR

 . S DIE="^LR("_LRDFN_",""MI"",",DA=LRIDT,DA(1)=LRDFN

 . ;S DR=.9

 . ;I '$G(LRQUIET) W:DR'=.9 !!,"Order comment:"

 . S DR=.99_$S($L($G(LRGCOM)):"///"_LRGCOM,$L($G(LRCCOM)):"//"_LRCCOM,1:"")

 . I '$G(LRQUIET) W:DR'=.99 !!,"Order comment:"

 . D ^DIE

 I '$G(LRQUIET),'$D(LRPHSET),'$D(LRGCOM) W !,"Description OK? Y//" D % G ST4:%["N"

 K DR,DIC,DIE

 Q

 ;

 ;

ST5 S I("SUBSC")=$S(I("EDIT")[11.5:26,I("EDIT")[15:27,I("EDIT")[19:28,I("EDIT")[23:29,I("EDIT")[34:30,1:-1) Q:I("SUBSC")=-1

 S I("PNTR")=$S(I("EDIT")[11.5:"^63.061A^",I("EDIT")[15:"^63.361A^",I("EDIT")[19:"^63.111A^",I("EDIT")[23:"^63.181A^",1:"^63.432A^")

 S I("N")=1+$S($D(^LR(LRDFN,"MI",LRIDT,I("SUBSC"),0)):$P(^(0),U,4),1:0),^(0)=I("PNTR")_I("N")_U_I("N"),^(I("N"),0)=I("TEST")

 Q

 ;

 ;

SET S LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX),LRIN=$P(LRTS,U,3),LRORIFN=$P(LRTS,U,4),LRTSORU=+$P(LRTS,U,6),LRTS=$P(LRTS,U,1,2),LRBACK=$P(LRTS,U,5)

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

 D ENTRYAUD^BLRUTIL("SET^LRWLST11 0.0","LRTS")

 ; NEW OLDLRQ

 ; S OLDLRQ=$G(LRQUIET)

 ; NEW LRQUIET

 ; I $$REFLAB^BLRUTIL6(DUZ(2),$S(+$G(LRY):+$G(LRY),+$G(LRTSTS):+$G(LRTSTS),1:0)) S LRQUIET=1

 ; E  S LRQUIET=$G(OLDLRQ)

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

 ;

 ;

 ; I '$G(LRQUIET),'$D(LRPHSET) D

 ; 

 ; I '$G(BLRGUI),'$G(LRQUIET),'$D(LRPHSET) D  ; IHS/OIT/MKK - LR*5.2*1027

 ; . W !,$P(^LAB(60,+LRTS,0),U)

 ; . I $D(LRSPEC),LRSPEC D

 ; . . S I=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),J=$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"")

 ; . . W ?30,J W:I'=J "  ",I

 ;

 ; ------ BEGIN IHS/MSC/MKK - LR*5.2*1035

 I '$G(BLRGUI),'$G(LRQUIET),'$D(LRPHSET) D  ; IHS/OIT/MKK - LR*5.2*1027

 . W !,$P(^LAB(60,+LRTS,0),U)

 . ;

 . NEW IEN,LRSAMP,LRSPEC,LRASIEN

 . S LRASIEN="1,"_LRAN_","_LRAD_","_LRAA

 . S LRSPEC=$$GET1^DIQ(68.05,LRASIEN,.01)

 . S LRSAMP=$$GET1^DIQ(68.05,LRASIEN,1)

 . ;

 . I $L(LRSPEC) D

 .. W ?30

 .. W:$L(LRSAMP) LRSAMP

 .. W:$L(LRSAMP)&(LRSPEC'=LRSAMP) "  ",LRSPEC

 .. W:$L(LRSAMP)<1 LRSPEC

 ; ------ END IHS/MSC/MKK - LR*5.2*1035

 ;

 ; I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D

 I '$G(BLRGUI),'$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D      ; IHS/MSC/MKK - LR*5.2*1031

 . N S

 . S DIC="^LAB(60,",DA=+LRTS,DR=7

 . D ENTRYAUD^BLRUTIL("SET^LRWLST11 7.0")

 . D EN^DIQ H 3

 ; I '$G(LRQUIET),'$D(LRPHSET),+LRTS D

 I '$G(BLRGUI),'$G(LRQUIET),'$D(LRPHSET),+LRTS D           ; IHS/MSC/MKK - LR*5.2*1031

 . N S

 . S DIC="^LAB(60,"_(+LRTS)_",3,"

 . S DA=+$O(^LAB(60,+LRTS,3,"B",+LRSAMP,0)),DR=2

 . D:DA ENTRYAUD^BLRUTIL("SET^LRWLST11 7.5")

 . I DA>0,$O(^LAB(60,+LRTS,3,DA,2,0))>0 D EN^DIQ H 3

 ;

 D ORUT

 D CAP^LRWLST12

 ;

 S:'$G(LRSPEC) LRSPEC=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),U)                  ; IHS/MSC/MKK - LR*5.2*1031

 ;

 K LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)

 ;

 S ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK

 S ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)=""

 ;

 ; When file 63 is enhanced to accept comments per test comments should

 ; be put there instead of field 99.

 I $O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0)) D

 . I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q

 . S X=$S($D(^LR(LRDFN,LRSS,LRIDT,1,0)):$P(^(0),"^",3),1:0),I=0

 . F  S I=$O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,I)) Q:I<1  S II=^(I,0) S X=X+1,^LR(LRDFN,LRSS,LRIDT,1,X,0)=II

 . S:X ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X

 ;

RUID I $G(LRORU3)'="" D

 . N DA,DIE,DIC,DLAYGO,DR,X,Y

 . S DLAYGO=69

 . S DA=LRIN,DA(1)=LRSN,DA(2)=LRODT,DIC="^LRO(69,"_DA(2)_",1,"_DA(1)_",2,"

 . S DIE=DIC,DR="13////"_$P(LRORU3,U)_";14////"_$P(LRORU3,U,2)_";15////"_$P(LRORU3,U,3)_";16////"_$P(LRORU3,U,4)_";17////"_$P(LRORU3,U,5)

 . D ^DIE

 Q

 ;

 ;

% R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %

 ;

 ;

LRCCOM ;

 N I,LRCCOM,LRTN,X

 S (I,LRTN,LRCCOM)=0 Q:LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0)

 F  S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1  I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X

 F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'LRTN  I $D(^(LRTN,0)) S X=^(0) I $P(X,"^",8),'$P(X,"^",3),$O(^(1,0)) D  ;Get comments for expanded panels

 . S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,1,I)) Q:'I  I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X

 S:LRCCOM ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM

 Q

 ;

 ;

Z ; L +^LRO(69.1,LRTE)

 Q:+$G(LRTE)<1     ; IHS/OIT/MKK - LR*5.2*1031

 ;

 ; L +^LRO(69.1,LRTE)

 L +^LRO(69.1,LRTE):5  Q:'$T      ; IHS/MSC/MKK - LR*5.2*1035

 ;

 S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0)

Z1 S LRZ3=LRZ3+1 G:$D(^LRO(69.1,LRTE,1,LRZ3)) Z1

 S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTS,LRIFN=LRZ3

 D Z^LRWU

 S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTS_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_+LROLLOC

 S ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTS)=+LRTS

 L -^LRO(69.1,LRTE)

 Q

 ;

 ;

ORUT Q:'$G(LRTSORU)!($G(LRSS)'="CH")

 N LRTT,DLAYGO,DIC,DIE,DR,LRTST,DA,LRURG

 S DA=LRIDT,DA(1)=LRDFN

 S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1  Q:$D(^LR(DA(1),LRSS,DA,"ORUT","B",LRNLT))

 S DR=".35///^S X=LRNLT",DR(1)=".35"

 S DR(1,63.04)=".35///^S X=LRNLT"

 S DR(1,63.07)=".01///^S X=LRNLT"

 S DIC="^LR("_DA(1)_","""_LRSS_""","

 S DIC(0)="MNL",DIE=DIC W:$G(LRDBUG) !,LRNLT

 D ^DIE

 ;

ORUT2 S LRTST=$P($G(^LAM($O(^LAM("E",LRNLT,0)),0)),U) Q:LRTST=""!('$G(LR696IEN))

 Q:'($D(^LRO(69.6,LR696IEN,0))#2)!($D(^LRO(69.6,LR696IEN,2,"C",LRNLT)))

 S:'$D(^LRO(69.6,LR696IEN,2,0)) ^(0)="^69.64A^"

 S DLAYGO=69.6

 K DIC,DIE,DA,DR,DA

 S DA=LR696IEN

 S LRURG="R",LRURG=$S($L($P($G(^LAB(62.05,+$P(LRTS,U,2),0)),U,4)):$P(^(0),U,4),1:LRURG)

 S (DIE,DIC)="^LRO(69.6,",DIC(0)="LM"

 S DR=20_"///"_LRTST_";",DR(1,69.6)="20///"_LRTST_";"

 S DR(2,69.64)=".01///"_LRTST_";1///"_LRNLT_";4///"_LRURG_";5////160;8///"_LRNT_";9///"_LRUID

 D ^DIE

 Q

 ;

 ;

SICA ; Check accessions 'in common' and setup reference to this accession

 N FDA,LR6802,LRDIE,LRAA

 S LRX=$P($G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.2)),"^"),LRAA=0

 F  S LRAA=$O(LRTSTS(LRWLC,LRUNQ,LRAA)) Q:LRAA<1  I LRWLC'=LRAA D

 . S LR6802=LRAN_","_LRAD_","_LRAA_","

 . S FDA(5,68.02,LR6802,15.1)=LRX

 . D FILE^DIE("","FDA(5)","LRDIE(5)")

 . ; I $D(LRDIE(5)) D MAILALRT^LRWLST1

 . I $D(LRDIE(5)) D MAILALRT^LRWLST1("7 SICA")        ; IHS/MSC/MKK - LR*5.2*1031

 Q

LRWLST11  ;DALOI/CJS,RWF/FHS - ACCESSION SETUP ; 01-May-2015 06:30 ; MKK

 +1       ;;5.2;LAB SERVICE;**121,128,153,202,1018,286,1027,331,375,1031,1034,1035**;NOV 01, 1997;Build 5

 +2       ;

 +3       ;

ST21      ;

 +1        SET LRTS=""

           SET LRIX=0

 +2        FOR 

               SET LRIX=$ORDER(LRTSTS(LRWLC,LRUNQ,LRAA,LRIX))

               IF LRIX<1

                   QUIT 

               DO SET

               IF LRUNQ

                   QUIT 

 +3       ;

 +4        SET LRNT=$$NOW^XLFDT

 +5        DO SCDT

           DO SLRSS

 +6       ;

COMMON    ; Setup 'in common' accession if not already setup unless it will be 

 +1       ; when tests are acessioned to the 'in common' area.

 +2        IF +LRWLC

               IF +LRWLC'=+LRAA

                   IF $GET(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$GET(LRDFN)

                       Begin DoDot:1

 +3                        IF 'LRUNQ

                               IF $DATA(LRTSTS(LRWLC,LRUNQ,LRWLC))

                                   QUIT 

 +4                        IF $GET(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1))

                               QUIT 

 +5                        NEW LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y

 +6                        SET (LRQUIET,LRCOMMON)=1

                           SET LRAA=+LRWLC

                           SET LRORDRR=""

 +7                        SET X=LRSS

                           SET LRCDTX=LRCDT

 +8                        NEW LRCDT,LRSS

 +9                        SET LRCDT=LRCDTX

                           SET LRSS=X_U_(1+$GET(LRLBLBP))

 +10                       DO STWLN^LRWLST1

                           IF $GET(LREND)

                               QUIT 

 +11                       DO ST2^LRWLST1

                           IF $GET(LREND)

                               QUIT 

 +12                       DO SCDT

                           DO SLRSS

                       End DoDot:1

 +13      ;

 +14       QUIT 

 +15      ;

 +16      ;

SCDT      ; Set collection, inverse and lab arrival date/times on accession

 +1        NEW FDA,LR6802,LRDIE

 +2        SET LR6802=LRAN_","_LRAD_","_LRAA_","

 +3        SET FDA(4,68.02,LR6802,9)=LRCDT

 +4        SET FDA(4,68.02,LR6802,10)=LREAL

 +5        IF '$DATA(LRPHSET)

               SET FDA(4,68.02,LR6802,12)=LRNT

 +6        SET FDA(4,68.02,LR6802,13.5)=LRIDT

 +7        DO FILE^DIE("","FDA(4)","LRDIE(4)")

 +8       ; I $D(LRDIE(4)) D MAILALRT^LRWLST1

 +9       ; IHS/MSC/MKK - LR*5.2*1031

           IF $DATA(LRDIE(4))

               DO MAILALRT^LRWLST1("7 SCDT")

 +10       QUIT 

 +11      ;

 +12      ;

SLRSS     ;

 +1       ;

 +2       ; change for AP

           SET X=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))

 +3        SET H8=$SELECT($DATA(LRSPEC):LRSPEC,1:X)_U_$SELECT("CYEMSPAU"[LRSS:LRACC,1:LRACC)_U_$SELECT(LRSS="MI":LRPRAC,1:"")_U_$SELECT(LRSS="MI":LRLLOC,1:"")_"^^"_$SELECT(LRSS="CH":LRPRAC,1:"")_"^"_$SELECT(LRSS="MI":$PIECE(LRSAMP,";",1),LRSS="CH":LRLLOC,

1:"")

 +4       ;

 +5        IF $SELECT(LRSS="CH":1,LRSS="MI":1,1:0)

               Begin DoDot:1

 +6                IF $GET(LRORDRR)="R"

                       IF +$GET(LRRSITE("RSITE"))

                           SET $PIECE(H8,U,9)=+LRRSITE("RSITE")_";DIC(4,"

 +7                IF $GET(LROLLOC)

                       IF $GET(LRORDRR)'="R"

                           SET $PIECE(H8,U,9)=LROLLOC_";SC("

 +8                SET $PIECE(H8,U,10)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),1:$GET(DUZ(2)))

               End DoDot:1

 +9       ;

 +10       SET ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8

 +11       IF $GET(LRORU3)'=""

               SET ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3

 +12      ;

ST3        IF (LRSS="MI")

               DO ST4

           DO LRCCOM

 +1       ;

 +2        SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

           SET DFN=$PIECE(^(0),U,3)

           SET LRPR=1

 +3        SET LRRB=0

 +4        IF LRDPF=2

               SET LRRB=$$GET1^DIQ(2,DFN_",",.101)

               SET LRRB=$SELECT(LRRB'="":LRRB,1:0)

 +5       ;

 +6        IF $GET(LRORDR)="P"

               QUIT 

 +7       ;

 +8        IF '$DATA(LRTJ)

               Begin DoDot:1

 +9       ; Don't print, use label from sending facility.

                   IF $GET(LRORDRR)="R"

                       IF LRSS="CH"

                           IF $GET(LRORU3)'=""

                               IF $PIECE(LRORU3,"^")'=$PIECE(LRORU3,"^",4)

                                   QUIT 

 +10               IF LRLBLBP

                       IF '$GET(LRCOMMON)

                           SET LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$SELECT($DATA(LRORD):LRORD,1:"")

               End DoDot:1

               QUIT 

 +11       SET I=0

 +12       FOR 

               SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))

               IF I<.5

                   QUIT 

               SET LRTS=^(I,0)

               DO Z

 +13       QUIT 

 +14      ;

 +15      ;

ST4       ;

 +1        SET $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$SELECT($DATA(LRNT):LRNT,1:"")

           SET $PIECE(^(0),U,8)=LRLLOC

 +2       ; Used to be LRSPCDSC,63.05,.9 (Word Processing field) replaces 63.05,.99

 +3        IF $DATA(LRCCOM)

               SET ^LR(LRDFN,LRSS,LRIDT,99)=LRCCOM

 +4        IF '$DATA(LRPHSET)

               Begin DoDot:1

 +5                NEW DA,DIE,DR

 +6                SET DIE="^LR("_LRDFN_",""MI"","

                   SET DA=LRIDT

                   SET DA(1)=LRDFN

 +7       ;S DR=.9

 +8       ;I '$G(LRQUIET) W:DR'=.9 !!,"Order comment:"

 +9                SET DR=.99_$SELECT($LENGTH($GET(LRGCOM)):"///"_LRGCOM,$LENGTH($GET(LRCCOM)):"//"_LRCCOM,1:"")

 +10               IF '$GET(LRQUIET)

                       IF DR'=.99

                           WRITE !!,"Order comment:"

 +11               DO ^DIE

               End DoDot:1

 +12       IF '$GET(LRQUIET)

               IF '$DATA(LRPHSET)

                   IF '$DATA(LRGCOM)

                       WRITE !,"Description OK? Y//"

                       DO %

                       IF %["N"

                           GOTO ST4

 +13       KILL DR,DIC,DIE

 +14       QUIT 

 +15      ;

 +16      ;

ST5        SET I("SUBSC")=$SELECT(I("EDIT")[11.5:26,I("EDIT")[15:27,I("EDIT")[19:28,I("EDIT")[23:29,I("EDIT")[34:30,1:-1)

           IF I("SUBSC")=-1

               QUIT 

 +1        SET I("PNTR")=$SELECT(I("EDIT")[11.5:"^63.061A^",I("EDIT")[15:"^63.361A^",I("EDIT")[19:"^63.111A^",I("EDIT")[23:"^63.181A^",1:"^63.432A^")

 +2        SET I("N")=1+$SELECT($DATA(^LR(LRDFN,"MI",LRIDT,I("SUBSC"),0)):$PIECE(^(0),U,4),1:0)

           SET ^(0)=I("PNTR")_I("N")_U_I("N")

           SET ^(I("N"),0)=I("TEST")

 +3        QUIT 

 +4       ;

 +5       ;

SET        SET LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)

           SET LRIN=$PIECE(LRTS,U,3)

           SET LRORIFN=$PIECE(LRTS,U,4)

           SET LRTSORU=+$PIECE(LRTS,U,6)

           SET LRTS=$PIECE(LRTS,U,1,2)

           SET LRBACK=$PIECE(LRTS,U,5)

 +1       ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

 +2        DO ENTRYAUD^BLRUTIL("SET^LRWLST11 0.0","LRTS")

 +3       ; NEW OLDLRQ

 +4       ; S OLDLRQ=$G(LRQUIET)

 +5       ; NEW LRQUIET

 +6       ; I $$REFLAB^BLRUTIL6(DUZ(2),$S(+$G(LRY):+$G(LRY),+$G(LRTSTS):+$G(LRTSTS),1:0)) S LRQUIET=1

 +7       ; E  S LRQUIET=$G(OLDLRQ)

 +8       ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034

 +9       ;

 +10      ;

 +11      ; I '$G(LRQUIET),'$D(LRPHSET) D

 +12      ; 

 +13      ; I '$G(BLRGUI),'$G(LRQUIET),'$D(LRPHSET) D  ; IHS/OIT/MKK - LR*5.2*1027

 +14      ; . W !,$P(^LAB(60,+LRTS,0),U)

 +15      ; . I $D(LRSPEC),LRSPEC D

 +16      ; . . S I=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),J=$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"")

 +17      ; . . W ?30,J W:I'=J "  ",I

 +18      ;

 +19      ; ------ BEGIN IHS/MSC/MKK - LR*5.2*1035

 +20      ; IHS/OIT/MKK - LR*5.2*1027

           IF '$GET(BLRGUI)

               IF '$GET(LRQUIET)

                   IF '$DATA(LRPHSET)

                       Begin DoDot:1

 +21                       WRITE !,$PIECE(^LAB(60,+LRTS,0),U)

 +22      ;

 +23                       NEW IEN,LRSAMP,LRSPEC,LRASIEN

 +24                       SET LRASIEN="1,"_LRAN_","_LRAD_","_LRAA

 +25                       SET LRSPEC=$$GET1^DIQ(68.05,LRASIEN,.01)

 +26                       SET LRSAMP=$$GET1^DIQ(68.05,LRASIEN,1)

 +27      ;

 +28                       IF $LENGTH(LRSPEC)

                               Begin DoDot:2

 +29                               WRITE ?30

 +30                               IF $LENGTH(LRSAMP)

                                       WRITE LRSAMP

 +31                               IF $LENGTH(LRSAMP)&(LRSPEC'=LRSAMP)

                                       WRITE "  ",LRSPEC

 +32                               IF $LENGTH(LRSAMP)<1

                                       WRITE LRSPEC

                               End DoDot:2

                       End DoDot:1

 +33      ; ------ END IHS/MSC/MKK - LR*5.2*1035

 +34      ;

 +35      ; I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D

 +36      ; IHS/MSC/MKK - LR*5.2*1031

           IF '$GET(BLRGUI)

               IF '$GET(LRQUIET)

                   IF '$DATA(LRPHSET)

                       IF +LRTS

                           IF $ORDER(^LAB(60,+LRTS,7,0))>0

                               Begin DoDot:1

 +37                               NEW S

 +38                               SET DIC="^LAB(60,"

                                   SET DA=+LRTS

                                   SET DR=7

 +39                               DO ENTRYAUD^BLRUTIL("SET^LRWLST11 7.0")

 +40                               DO EN^DIQ

                                   HANG 3

                               End DoDot:1

 +41      ; I '$G(LRQUIET),'$D(LRPHSET),+LRTS D

 +42      ; IHS/MSC/MKK - LR*5.2*1031

           IF '$GET(BLRGUI)

               IF '$GET(LRQUIET)

                   IF '$DATA(LRPHSET)

                       IF +LRTS

                           Begin DoDot:1

 +43                           NEW S

 +44                           SET DIC="^LAB(60,"_(+LRTS)_",3,"

 +45                           SET DA=+$ORDER(^LAB(60,+LRTS,3,"B",+LRSAMP,0))

                               SET DR=2

 +46                           IF DA

                                   DO ENTRYAUD^BLRUTIL("SET^LRWLST11 7.5")

 +47                           IF DA>0

                                   IF $ORDER(^LAB(60,+LRTS,3,DA,2,0))>0

                                       DO EN^DIQ

                                       HANG 3

                           End DoDot:1

 +48      ;

 +49       DO ORUT

 +50       DO CAP^LRWLST12

 +51      ;

 +52      ; IHS/MSC/MKK - LR*5.2*1031

           IF '$GET(LRSPEC)

               SET LRSPEC=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),U)

 +53      ;

 +54       KILL LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)

 +55      ;

 +56       SET ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK

 +57       SET ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)=""

 +58      ;

 +59      ; When file 63 is enhanced to accept comments per test comments should

 +60      ; be put there instead of field 99.

 +61       IF $ORDER(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0))

               Begin DoDot:1

 +62               IF LRSS'="CH"!($DATA(^LR(LRDFN,LRSS,LRIDT,0))[0)

                       QUIT 

 +63               SET X=$SELECT($DATA(^LR(LRDFN,LRSS,LRIDT,1,0)):$PIECE(^(0),"^",3),1:0)

                   SET I=0

 +64               FOR 

                       SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRIN,1,I))

                       IF I<1

                           QUIT 

                       SET II=^(I,0)

                       SET X=X+1

                       SET ^LR(LRDFN,LRSS,LRIDT,1,X,0)=II

 +65               IF X

                       SET ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X

               End DoDot:1

 +66      ;

RUID       IF $GET(LRORU3)'=""

               Begin DoDot:1

 +1                NEW DA,DIE,DIC,DLAYGO,DR,X,Y

 +2                SET DLAYGO=69

 +3                SET DA=LRIN

                   SET DA(1)=LRSN

                   SET DA(2)=LRODT

                   SET DIC="^LRO(69,"_DA(2)_",1,"_DA(1)_",2,"

 +4                SET DIE=DIC

                   SET DR="13////"_$PIECE(LRORU3,U)_";14////"_$PIECE(LRORU3,U,2)_";15////"_$PIECE(LRORU3,U,3)_";16////"_$PIECE(LRORU3,U,4)_";17////"_$PIECE(LRORU3,U,5)

 +5                DO ^DIE

               End DoDot:1

 +6        QUIT 

 +7       ;

 +8       ;

%          READ %:DTIME

           IF %=""!(%["N")!(%["Y")

               QUIT 

           WRITE !,"Answer 'Y' or 'N': "

           GOTO %

 +1       ;

 +2       ;

LRCCOM    ;

 +1        NEW I,LRCCOM,LRTN,X

 +2        SET (I,LRTN,LRCCOM)=0

           IF LRSS'="CH"!($DATA(^LR(LRDFN,LRSS,LRIDT,0))[0)

               QUIT 

 +3        FOR 

               SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,I))

               IF I<1

                   QUIT 

               IF $DATA(^(I,0))

                   SET X=^(0)

                   SET LRCCOM=LRCCOM+1

                   SET ^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X

 +4       ;Get comments for expanded panels

           FOR 

               SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))

               IF 'LRTN

                   QUIT 

               IF $DATA(^(LRTN,0))

                   SET X=^(0)