LRWLST11 ;DALOI/STAFF - ACCESSION SETUP ;Mar 27, 2008
;;5.2;LAB SERVICE;**121,128,153,202,286,331,375,350,440,461**;Sep 27, 1994;Build 15
;
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 accessioned 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^LRWLST12("SCDT~LRWLST11")
Q
;
;
;
N FDA,FDAIEN,LRDIE,LRX
S LRX=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="BB":63.01,1:0)
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:LRNT)_"^"_$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)))
;
D SLRSS^LRWLST1A
;allow labels to print for Anatomic Pathology accessions
;by commenting out the line below
;(The two lines below that were already commented out.)
;Q:"SPEMCY"[LRSS
;S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8
;I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3
;
ST3 ;
I LRSS="MI" D ST4
D 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 $G(LRLBLBP),'$G(LRCOMMON) S LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$S($D(LRORD):LRORD,1:"")
;Anatomic Pathology labels do not print on collection lists
Q:"SPEMCY"[LRSS
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)
S LRIN=$P(LRTS,U,3),LRORIFN=$P(LRTS,U,4),LRTSORU=+$P(LRTS,U,6),LRBACK=$P(LRTS,U,5),LRTS=$P(LRTS,U,1,2)
;
I '$G(LRQUIET),'$D(LRPHSET) D
. 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
;
I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D
. N S
. S DIC="^LAB(60,",DA=+LRTS,DR=7
. D EN^DIQ H 3
I '$G(LRQUIET),'$D(LRPHSET),+LRTS D
. N S
. S DIC="^LAB(60,"_(+LRTS)_",3,"
. S DA=+$O(^LAB(60,+LRTS,3,"B",+LRSAMP,0)),DR=2
. I DA>0,$O(^LAB(60,+LRTS,3,DA,2,0))>0 D EN^DIQ H 3
;
D ORUT
;
; Check if LEDI specimen being accessioned then
; - update test status of order in file #69.6
; - if LEDI AP specimen copy data accompanying order from file #69.6 to file #63
; - update remote ordering provider from file #69.6 to ordered test multiple (#.35)
I $G(LRORDRR)="R",$G(LR696)>0 D
. D ORUT2^LRWLST12
. D PROVCPY^LRWLST12
. I "SPCYEM"[LRSS D APMOVE^LRWLST12
;
D CAP^LRWLST12
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 ; Copy comments from file #69 to file #63 comment multiple
N I,LRCCOM,LRTN,X
S (I,LRTN,LRCCOM)=0
;
I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q
;
; Copy (#16) WARD COMMENTS ON SPECIMEN to file #63 comment multiple
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
;
; Copy expanded panels (#99) TEST COMMENTS to file #63 comment multiple
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
. 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 ; Update collection list (#69.1)
L +^LRO(69.1,LRTE):999
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 ;Set ORUT/ordered test node in file 63
;LRSS=subscript-required
;LRIDT=inverse date-required
;LRDFN=IEN file 63-required
;LRTSORU=ordered test (file #60 IEN)-required
;LRURG=ordered urgency
;LRORIFN=CPRS order #
;LRORNUM=Lab order # LR_XXXX where XXXX is a julian date
;LRORTYP=ordered type
;LRPROVL=ordering provider local
;LRSPEC=specimen topography
;LRSAMP=Collection sample
;
N LRFDA,LRFILE,LRIEN,LRIENS,LRJUL,LRMSG,LRNLT,LRORNUM,LRORTYP
N LRPROVL,LRX,LRY,DIERR
S LRFILE=$S(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")
Q:'LRFILE!('$G(LRTSORU))
;
S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1
S LRORTYP=""
I $P($G(LRORDTYP),"^",2) S LRORTYP=$P(LRORDTYP,"^",2)
I LRORTYP="" D
. I $G(LRORDR)'="" S LRX=$S($G(LRORDR)="WC":"O",1:"L")
. I $G(LRORDR)="" S LRX=$S($G(LRORDRR)="R":"O",$G(LRLWC)="WC":"O",1:"L")
. S LRORTYP=$$FIND1^DIC(64.061,"","OX",LRX,"D","I $P(^(0),U,5)=""0065""")
S LRPROVL=$S($G(LRPRAC)?1.N:LRPRAC,1:"")
I $G(LRORD) D
. S LRX=$$FMDIFF^XLFDT(DT,$E(DT,1,3)_"0101",1)
. S LRX=LRX+1,LRJUL=$E("000",1,3-$L(LRX))_LRX
. S LRORNUM="LR-"_LRORD_"-"_$E(DT,1,3)_LRJUL
;
S LRIEN="?+1"_","_LRIDT_","_LRDFN_","
S LRFDA(5,LRFILE,LRIEN,.01)=LRNLT
I $G(LRURG) S LRFDA(5,LRFILE,LRIEN,2)=LRURG
I $G(LRORIFN) S LRFDA(5,LRFILE,LRIEN,3)=LRORIFN
I $G(LRORNUM)'="" S LRFDA(5,LRFILE,LRIEN,4)=LRORNUM
I LRORTYP'="" S LRFDA(5,LRFILE,LRIEN,5)=LRORTYP
I LRPROVL'="" S LRFDA(5,LRFILE,LRIEN,6)=LRPROVL
I $G(LRSPEC) S LRFDA(5,LRFILE,LRIEN,8)=LRSPEC
I $G(LRSAMP) S LRFDA(5,LRFILE,LRIEN,9)=LRSAMP
I +LRTSORU S LRFDA(5,LRFILE,LRIEN,13)=+LRTSORU
I $P($G(LRORDTYP),"^",3) D
. S LRFDA(5,LRFILE,LRIEN,14)=$P(LRORDTYP,"^",3)
. S LRFDA(5,LRFILE,LRIEN,15)=$P(LRORDTYP,"^",4)
D UPDATE^DIE("","LRFDA(5)","LRIENS","LRMSG")
D CLEAN^DILF
;
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
. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q
. K FDA,LRDIE
. 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^LRWLST12("SICA~LRWLST11")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWLST11 9631 printed Oct 16, 2024@18:23:46 Page 2
LRWLST11 ;DALOI/STAFF - ACCESSION SETUP ;Mar 27, 2008
+1 ;;5.2;LAB SERVICE;**121,128,153,202,286,331,375,350,440,461**;Sep 27, 1994;Build 15
+2 ;
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 accessioned 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 IF $DATA(LRDIE(4))
DO MAILALRT^LRWLST12("SCDT~LRWLST11")
+9 QUIT
+10 ;
+11 ;
+1 ;
+2 NEW FDA,FDAIEN,LRDIE,LRX
+3 SET LRX=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="BB":63.01,1:0)
+4 ; change for AP
SET X=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
+5 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:LRNT)_"^"_$SELECT(LRSS="MI":$PIECE(LRSAMP,";",1),LRSS="CH":LRLLO
C,1:"")
+6 ;
+7 IF $SELECT(LRSS="CH":1,LRSS="MI":1,1:0)
Begin DoDot:1
+8 IF $GET(LRORDRR)="R"
IF +$GET(LRRSITE("RSITE"))
SET $PIECE(H8,U,9)=+LRRSITE("RSITE")_";DIC(4,"
+9 IF $GET(LROLLOC)
IF $GET(LRORDRR)'="R"
SET $PIECE(H8,U,9)=LROLLOC_";SC("
+10 SET $PIECE(H8,U,10)=$SELECT($GET(LRDUZ(2)):LRDUZ(2),1:$GET(DUZ(2)))
End DoDot:1
+11 ;
+12 DO SLRSS^LRWLST1A
+13 ;allow labels to print for Anatomic Pathology accessions
+14 ;by commenting out the line below
+15 ;(The two lines below that were already commented out.)
+16 ;Q:"SPEMCY"[LRSS
+17 ;S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8
+18 ;I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3
+19 ;
ST3 ;
+1 IF LRSS="MI"
DO ST4
+2 DO LRCCOM
+3 ;
+4 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
SET LRPR=1
+5 SET LRRB=0
+6 IF LRDPF=2
SET LRRB=$$GET1^DIQ(2,DFN_",",.101)
SET LRRB=$SELECT(LRRB'="":LRRB,1:0)
+7 ;
+8 if $GET(LRORDR)="P"
QUIT
+9 ;
+10 IF '$DATA(LRTJ)
Begin DoDot:1
+11 ; 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
+12 IF $GET(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
+13 ;Anatomic Pathology labels do not print on collection lists
+14 if "SPEMCY"[LRSS
QUIT
+15 SET I=0
+16 FOR
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<.5
QUIT
SET LRTS=^(I,0)
DO Z
+17 ;
+18 QUIT
+19 ;
+20 ;
ST4 ;
+1 ;S $P(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$S($D(LRNT):LRNT,1:""),$P(^(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 ;
+1 SET LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)
+2 SET LRIN=$PIECE(LRTS,U,3)
SET LRORIFN=$PIECE(LRTS,U,4)
SET LRTSORU=+$PIECE(LRTS,U,6)
SET LRBACK=$PIECE(LRTS,U,5)
SET LRTS=$PIECE(LRTS,U,1,2)
+3 ;
+4 IF '$GET(LRQUIET)
IF '$DATA(LRPHSET)
Begin DoDot:1
+5 WRITE !,$PIECE(^LAB(60,+LRTS,0),U)
+6 IF $DATA(LRSPEC)
IF LRSPEC
Begin DoDot:2
+7 SET I=$SELECT($DATA(^LAB(61,+LRSPEC,0)):$PIECE(^(0),U),1:"")
SET J=$SELECT($DATA(^LAB(62,+LRSAMP,0)):$PIECE(^(0),U),1:"")
+8 WRITE ?30,J
if I'=J
WRITE " ",I
End DoDot:2
End DoDot:1
+9 ;
+10 IF '$GET(LRQUIET)
IF '$DATA(LRPHSET)
IF +LRTS
IF $ORDER(^LAB(60,+LRTS,7,0))>0
Begin DoDot:1
+11 NEW S
+12 SET DIC="^LAB(60,"
SET DA=+LRTS
SET DR=7
+13 DO EN^DIQ
HANG 3
End DoDot:1
+14 IF '$GET(LRQUIET)
IF '$DATA(LRPHSET)
IF +LRTS
Begin DoDot:1
+15 NEW S
+16 SET DIC="^LAB(60,"_(+LRTS)_",3,"
+17 SET DA=+$ORDER(^LAB(60,+LRTS,3,"B",+LRSAMP,0))
SET DR=2
+18 IF DA>0
IF $ORDER(^LAB(60,+LRTS,3,DA,2,0))>0
DO EN^DIQ
HANG 3
End DoDot:1
+19 ;
+20 DO ORUT
+21 ;
+22 ; Check if LEDI specimen being accessioned then
+23 ; - update test status of order in file #69.6
+24 ; - if LEDI AP specimen copy data accompanying order from file #69.6 to file #63
+25 ; - update remote ordering provider from file #69.6 to ordered test multiple (#.35)
+26 IF $GET(LRORDRR)="R"
IF $GET(LR696)>0
Begin DoDot:1
+27 DO ORUT2^LRWLST12
+28 DO PROVCPY^LRWLST12
+29 IF "SPCYEM"[LRSS
DO APMOVE^LRWLST12
End DoDot:1
+30 ;
+31 DO CAP^LRWLST12
+32 KILL LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)
+33 ;
+34 SET ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK
+35 SET ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)=""
+36 ;
+37 ; When file 63 is enhanced to accept comments per test comments should
+38 ; be put there instead of field 99.
+39 IF $ORDER(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0))
Begin DoDot:1
+40 IF LRSS'="CH"!($DATA(^LR(LRDFN,LRSS,LRIDT,0))[0)
QUIT
+41 SET X=$SELECT($DATA(^LR(LRDFN,LRSS,LRIDT,1,0)):$PIECE(^(0),"^",3),1:0)
SET I=0
+42 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
+43 if X
SET ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X
End DoDot:1
+44 ;
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 ; Copy comments from file #69 to file #63 comment multiple
+1 NEW I,LRCCOM,LRTN,X
+2 SET (I,LRTN,LRCCOM)=0
+3 ;
+4 IF LRSS'="CH"!($DATA(^LR(LRDFN,LRSS,LRIDT,0))[0)
QUIT
+5 ;
+6 ; Copy (#16) WARD COMMENTS ON SPECIMEN to file #63 comment multiple
+7 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
+8 ;
+9 ; Copy expanded panels (#99) TEST COMMENTS to file #63 comment multiple
+10 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
+11 SET I=0
+12 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
+13 ;
+14 if LRCCOM
SET ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM
+15 ;
+16 QUIT
+17 ;
+18 ;
Z ; Update collection list (#69.1)
+1 LOCK +^LRO(69.1,LRTE):999
+2 SET LRZ3=$SELECT($DATA(^LRO(69.1,LRTE,1,0)):$PIECE(^(0),U,3),1:0)
+3 ;
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 ;Set ORUT/ordered test node in file 63
+1 ;LRSS=subscript-required
+2 ;LRIDT=inverse date-required
+3 ;LRDFN=IEN file 63-required
+4 ;LRTSORU=ordered test (file #60 IEN)-required
+5 ;LRURG=ordered urgency
+6 ;LRORIFN=CPRS order #
+7 ;LRORNUM=Lab order # LR_XXXX where XXXX is a julian date
+8 ;LRORTYP=ordered type
+9 ;LRPROVL=ordering provider local
+10 ;LRSPEC=specimen topography
+11 ;LRSAMP=Collection sample
+12 ;
+13 NEW LRFDA,LRFILE,LRIEN,LRIENS,LRJUL,LRMSG,LRNLT,LRORNUM,LRORTYP
+14 NEW LRPROVL,LRX,LRY,DIERR
+15 SET LRFILE=$SELECT(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")
+16 if 'LRFILE!('$GET(LRTSORU))
QUIT
+17 ;
+18 SET LRNLT=$$NLT^LRVER1(+LRTSORU)
if +LRNLT<1
QUIT
+19 SET LRORTYP=""
+20 IF $PIECE($GET(LRORDTYP),"^",2)
SET LRORTYP=$PIECE(LRORDTYP,"^",2)
+21 IF LRORTYP=""
Begin DoDot:1
+22 IF $GET(LRORDR)'=""
SET LRX=$SELECT($GET(LRORDR)="WC":"O",1:"L")
+23 IF $GET(LRORDR)=""
SET LRX=$SELECT($GET(LRORDRR)="R":"O",$GET(LRLWC)="WC":"O",1:"L")
+24 SET LRORTYP=$$FIND1^DIC(64.061,"","OX",LRX,"D","I $P(^(0),U,5)=""0065""")
End DoDot:1
+25 SET LRPROVL=$SELECT($GET(LRPRAC)?1.N:LRPRAC,1:"")
+26 IF $GET(LRORD)
Begin DoDot:1
+27 SET LRX=$$FMDIFF^XLFDT(DT,$EXTRACT(DT,1,3)_"0101",1)
+28 SET LRX=LRX+1
SET LRJUL=$EXTRACT("000",1,3-$LENGTH(LRX))_LRX
+29 SET LRORNUM="LR-"_LRORD_"-"_$EXTRACT(DT,1,3)_LRJUL
End DoDot:1
+30 ;
+31 SET LRIEN="?+1"_","_LRIDT_","_LRDFN_","
+32 SET LRFDA(5,LRFILE,LRIEN,.01)=LRNLT
+33 IF $GET(LRURG)
SET LRFDA(5,LRFILE,LRIEN,2)=LRURG
+34 IF $GET(LRORIFN)
SET LRFDA(5,LRFILE,LRIEN,3)=LRORIFN
+35 IF $GET(LRORNUM)'=""
SET LRFDA(5,LRFILE,LRIEN,4)=LRORNUM
+36 IF LRORTYP'=""
SET LRFDA(5,LRFILE,LRIEN,5)=LRORTYP
+37 IF LRPROVL'=""
SET LRFDA(5,LRFILE,LRIEN,6)=LRPROVL
+38 IF $GET(LRSPEC)
SET LRFDA(5,LRFILE,LRIEN,8)=LRSPEC
+39 IF $GET(LRSAMP)
SET LRFDA(5,LRFILE,LRIEN,9)=LRSAMP
+40 IF +LRTSORU
SET LRFDA(5,LRFILE,LRIEN,13)=+LRTSORU
+41 IF $PIECE($GET(LRORDTYP),"^",3)
Begin DoDot:1
+42 SET LRFDA(5,LRFILE,LRIEN,14)=$PIECE(LRORDTYP,"^",3)
+43 SET LRFDA(5,LRFILE,LRIEN,15)=$PIECE(LRORDTYP,"^",4)
End DoDot:1
+44 DO UPDATE^DIE("","LRFDA(5)","LRIENS","LRMSG")
+45 DO CLEAN^DILF
+46 ;
+47 QUIT
+48 ;
+49 ;
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 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+5 KILL FDA,LRDIE
+6 SET LR6802=LRAN_","_LRAD_","_LRAA_","
+7 SET FDA(5,68.02,LR6802,15.1)=LRX
+8 DO FILE^DIE("","FDA(5)","LRDIE(5)")
+9 IF $DATA(LRDIE(5))
DO MAILALRT^LRWLST12("SICA~LRWLST11")
End DoDot:1
+10 QUIT
