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
;
;
;
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 ;
+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)
IF $PIECE(X,"^",8)
IF '$PIECE(X,"^",3)
IF $ORDER(^(1,0))
Begin DoDot:1
+5 SET I=0
FOR
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN,1,I))
IF 'I
QUIT
IF $DATA(^(I,0))
SET X=^(0)
SET LRCCOM=LRCCOM+1
SET ^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
End DoDot:1
+6 IF LRCCOM
SET ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM
+7 QUIT
+8 ;
+9 ;
Z ; L +^LRO(69.1,LRTE)
+1 ; IHS/OIT/MKK - LR*5.2*1031
IF +$GET(LRTE)<1
QUIT
+2 ;
+3 ; L +^LRO(69.1,LRTE)
+4 ; IHS/MSC/MKK - LR*5.2*1035
LOCK +^LRO(69.1,LRTE):5
IF '$TEST
QUIT
+5 ;
+6 SET LRZ3=$SELECT($DATA(^LRO(69.1,LRTE,1,0)):$PIECE(^(0),U,3),1:0)
Z1 SET LRZ3=LRZ3+1
IF $DATA(^LRO(69.1,LRTE,1,LRZ3))
GOTO Z1
+1 SET LRZO="^LRO(69.1,"_LRTE_",1,"
SET LRZ1="69.11P"
SET LRZB=+LRTS
SET LRIFN=LRZ3
+2 DO Z^LRWU
+3 SET ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTS_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_+LROLLOC
+4 SET ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN
SET ^(LRSN,LRAA,LRAN,+LRTS)=+LRTS
+5 LOCK -^LRO(69.1,LRTE)
+6 QUIT
+7 ;
+8 ;
ORUT IF '$GET(LRTSORU)!($GET(LRSS)'="CH")
QUIT
+1 NEW LRTT,DLAYGO,DIC,DIE,DR,LRTST,DA,LRURG
+2 SET DA=LRIDT
SET DA(1)=LRDFN
+3 SET LRNLT=$$NLT^LRVER1(+LRTSORU)
IF +LRNLT<1
QUIT
IF $DATA(^LR(DA(1),LRSS,DA,"ORUT","B",LRNLT))
QUIT
+4 SET DR=".35///^S X=LRNLT"
SET DR(1)=".35"
+5 SET DR(1,63.04)=".35///^S X=LRNLT"
+6 SET DR(1,63.07)=".01///^S X=LRNLT"
+7 SET DIC="^LR("_DA(1)_","""_LRSS_""","
+8 SET DIC(0)="MNL"
SET DIE=DIC
IF $GET(LRDBUG)
WRITE !,LRNLT
+9 DO ^DIE
+10 ;
ORUT2 SET LRTST=$PIECE($GET(^LAM($ORDER(^LAM("E",LRNLT,0)),0)),U)
IF LRTST=""!('$GET(LR696IEN))
QUIT
+1 IF '($DATA(^LRO(69.6,LR696IEN,0))#2)!($DATA(^LRO(69.6,LR696IEN,2,"C",LRNLT)))
QUIT
+2 IF '$DATA(^LRO(69.6,LR696IEN,2,0))
SET ^(0)="^69.64A^"
+3 SET DLAYGO=69.6
+4 KILL DIC,DIE,DA,DR,DA
+5 SET DA=LR696IEN
+6 SET LRURG="R"
SET LRURG=$SELECT($LENGTH($PIECE($GET(^LAB(62.05,+$PIECE(LRTS,U,2),0)),U,4)):$PIECE(^(0),U,4),1:LRURG)
+7 SET (DIE,DIC)="^LRO(69.6,"
SET DIC(0)="LM"
+8 SET DR=20_"///"_LRTST_";"
SET DR(1,69.6)="20///"_LRTST_";"
+9 SET DR(2,69.64)=".01///"_LRTST_";1///"_LRNLT_";4///"_LRURG_";5////160;8///"_LRNT_";9///"_LRUID
+10 DO ^DIE
+11 QUIT
+12 ;
+13 ;
SICA ; Check accessions 'in common' and setup reference to this accession
+1 NEW FDA,LR6802,LRDIE,LRAA
+2 SET LRX=$PIECE($GET(^LRO(68,LRWLC,1,LRAD,1,LRAN,.2)),"^")
SET LRAA=0
+3 FOR
SET LRAA=$ORDER(LRTSTS(LRWLC,LRUNQ,LRAA))
IF LRAA<1
QUIT
IF LRWLC'=LRAA
Begin DoDot:1
+4 SET LR6802=LRAN_","_LRAD_","_LRAA_","
+5 SET FDA(5,68.02,LR6802,15.1)=LRX
+6 DO FILE^DIE("","FDA(5)","LRDIE(5)")
+7 ; I $D(LRDIE(5)) D MAILALRT^LRWLST1
+8 ; IHS/MSC/MKK - LR*5.2*1031
IF $DATA(LRDIE(5))
DO MAILALRT^LRWLST1("7 SICA")
End DoDot:1
+9 QUIT
