LRAPLG1 ;DALOI/CKA,JMC,PMK - LOG-IN CONT. ;02/17/17 13:42
;;5.2;LAB SERVICE;**72,121,248,308,350,427,433,462,479,485**;Sep 27, 1994;Build 1
;
; Reference to DISP^SROSPLG supported by IA #893
;
START ; Start logging in the specimens.
N LRFND,LRMSG,LRXX
;
; Lock ^LR( and ^LRO
D LOCK^DILF("^LR(LRDFN,LRSS)")
I '$T D Q
. S LRMSG="This record is locked by another user. Please try later."
. D EN^DDIOL(LRMSG,"","!!")
;
D LOCK^DILF("^LRO(68,LRAA,1,LRAD,1,0)")
I '$T D Q
. L -^LR(LRDFN,LRSS)
. S LRMSG="Someone else is logging in specimens. Please wait and try again."
. D EN^DDIOL(LRMSG,"","!!")
;
; Check that accession date exists first
D CHECK68^LRWLST1(LRAA,LRAD)
;
EN ;
N LRAPDAN
;
S (LRI,LRIDT)=""
S LRAN=1
S LRAPDAN=$$GET^XPAR("ALL","LR AP DEFAULT ACCESSION NUMBER","`"_LRAA,"Q")
I LRAPDAN=2 S LRAN=+$P(^LRO(68,LRAA,1,LRAD,1,0),U,3)
F Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) S LRAN=LRAN+1
W !!,"Assign ",LRO(68)," (",LRABV,") accession #: ",LRAN S %=1 D YN^LRU
I %<1 L -^LRO(68,LRAA,1,LRAD,1,0),-^LR(LRDFN,LRSS) Q
;
I %=1,$D(LRXREF),$D(^LR(LRXREF,LRH(2),LRABV,LRAN)) D Q:$D(LRFND)
. I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),$P(^(0),U) S X=LRAN D ^LRUTELL S LRFND=1
. I '$D(LRFND) D ^LRAPLG2
. I $D(LRFND) L -^LRO(68,LRAA,1,LRAD,1,0),-^LR(LRDFN,LRSS) Q
. S %=0
;
I %=1 D CRE868 I $D(LRMSG) G EN
;
I %=2 D OS I $D(LRFND) K LRFND L -^LRO(68,LRAA,1,LRAD,1,0),-^LR(LRDFN,LRSS) Q
;
L -^LRO(68,LRAA,1,LRAD,1,0)
;
S LRAC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN
;
AU ; Autopsy Specific
I LRSS="AU" D ^LRAUAW Q
S:'$D(^LR(LRDFN,LRSS,0)) ^(0)="^"_LRSF_"DA^0^0"
;
; If orginal login then create entry in file #63
LR7OFA0 ;
I LRIDT="" D CRE863
I LRI="" Q
;
K DA,DTOUT,DIWESUB
;S DIWESUB=$E(PNM,1,27-$L(LRACC))_" ["_LRACC_"]"
S LR(.07)=$S($D(SRDOC):SRDOC,1:"") K SRDOC
S:LR(.07) LR(.07)=$P($G(^VA(200,LR(.07),0)),"^")
S DA=LRI,DA(1)=LRDFN
S DIC(0)="EQLMF",DLAYGO=63,DIE="^LR(LRDFN,LRSS,"
D @LR("L")
D ^DIE K DLAYGO
S:'$D(LRRC) LRRC=LRNT
;
; Check if topography and collection sample entered on each specimen.
; If not entered then define Y to cause entry to be deleted.
I LRSS?1(1"SP",1"CY",1"EM") D
. N I,LRJ,X
. S LRJ=0
. F S LRJ=$O(^LR(LRDFN,LRSS,LRI,.1,LRJ)) Q:LRJ<1 D Q:$D(Y)
. . S X=$G(^LR(LRDFN,LRSS,LRI,.1,LRJ,0))
. . F I=6,7 I $P(X,"^",I)="" S Y="" Q
;
; Delete entry if prompts not answered unless report has been released.
I $D(DTOUT)!$D(Y) D Q
. N DA,DIK
. I LRSS?1(1"SP",1"CY",1"EM"),($P(^LR(LRDFN,LRSS,LRI,0),"^",11)!$P(^LR(LRDFN,LRSS,LRI,0),"^",15)) Q
. W $C(7),!!,"All Prompts not answered - <ENTRY DELETED>"
. S DA(1)=LRDFN,DA=LRI
. S DIK="^LR("_DA(1)_","""_LRSS_""","
. D ^DIK,X,END
;
D GETSTCS ; Store specimen topography, coll sample in temp array
;
TST ; Get the ordered test and store in temp array
N II
D ORDTST
; Delete entry if no ordered tests unless report has been released.
I II=2 D Q
. I LRSS?1(1"SP",1"CY",1"EM"),($P(^LR(LRDFN,LRSS,LRI,0),"^",11)!$P(^LR(LRDFN,LRSS,LRI,0),"^",15)) Q
. N DA,DIK
. W $C(7),!!,"No ordered test selected - <ENTRY DELETED>"
. S DA(1)=LRDFN,DA=LRI,DIK="^LR("_DA(1)_","""_LRSS_""","
. D ^DIK,X,END
;
I LRSS="CY",LRCAPA D CK^LRAPCWK
;
; Check for surgery case references and move info if user wants surgical case info copied to Lab.
I LRSS="SP" D SPMOVE
;
; Fill out the stub accession with related info
I '$D(LRC(5)) S LRC(5)=""
D ^LRUWLF
;
I LRCAPA D
. I LRSS="CY" D ^LRAPCWK
. I LRSS?1(1"SP",1"EM") D ^LRAPSWK
;
I LRSS?1(1"SP",1"CY",1"EM") D ^LRSPGD
;
I $T(ADD^MAGTP005)'="" N MAGNEWCASE S MAGNEWCASE=1 D ADD^MAGTP005(LRAC) ; add case to file #2005.42 - P433
;
D OERR^LR7OB63D,LDSI
;
I $T(NEW^MAGT7MA)'="" D NEW^MAGT7MA ; invoke Imaging HL7 routine - P433
;
Q
;
;
LDSI ; LDSI tasks
;
N LRLLOC,LRALOC,LRPRAC,LROUTINE,LROPL,LRODT,LRNT,LRFILE,LRIENS,LRORD,LRSRDT,LRTST
;
; Get variables for ORUT node
S LROUTINE=$P($G(^LAB(69.9,1,3)),"^",2) ;default urgency
S LRPROVL=LRMD(1) ;Ordering provider-CKA
; Get ORDER TYPE
;;*
S:$G(LRORDR)="" LRORDR="WC" ;Default to 'Ward Collect' for now
;;;*
S LRNT=$$NOW^XLFDT() ;Date ordered = current date/time
S LRODT=$P(LRNT,".")
; Get Provider, Location abbrev, Collection date/time
S LRFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
S LRIENS=LRI_","_LRDFN_","
S LRPRAC=$$GET1^DIQ(LRFILE,LRIENS,.07,"I")
S LRLLOC=$$GET1^DIQ(LRFILE,LRIENS,.08,"I")
I LRLLOC="" S LRLLOC="NO ABRV"
S LRSDT=+$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
S LRSRDT=$$GET1^DIQ(LRFILE,LRIENS,.1,"I") ; Specimen received date/time
; Get CPRS Order #
S ORIFN="" ; Default to blank for now
;
; Get Lab Order #, update file #69 and #68
LDSI1 S (LRORD,LRSPEC,LRTST,LRSAMP,LRADD,LROT)="",LRCNT=1
F S LRSPEC=$O(LRXX(LRSPEC)) Q:'LRSPEC D
. N LRRECINF
. S LRSAMP=$P(LRXX(LRSPEC),"^",1),LRNLT=$P(LRXX(LRSPEC),"^",2),LRTST=$P(LRXX(LRSPEC),"^",3)
. Q:'LRTST
. ;I LRORD,$G(^LAB(69.9,1,21661)) S LRADD=1 D ZSN^LR7OFAO("",.LRRECINF)
. ; Get Lab Order # first time thru
. D:'LRORD EN^LR7OFAO(LRODT,LRDFN,LRSAMP,LRORDR,LRNT,LRPRAC,LRLLOC,LRSDT,ORIFN,LRSPEC,LRSS,LRTST,LRUID,.LRRECINF)
. S LRSN=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5),LRCDT=0,LREAL=""
. I LRSN>0 S LRCDT=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",1,2),LREAL=$P(LRCDT,"^",2),LRCDT=+LRCDT
. D UPD68,UPD63
. S LRCNT=LRCNT+1
;
Q
;
;
UPD68 ; Update #68 with required test data
N LRFILE,LRERR,IEN,LRIEN
S LRFILE=68.04,IEN(1)=LRTST
S LRIEN="?+1,"_LRAN_","_LRAD_","_LRAA_","
S FDA(3,LRFILE,LRIEN,.01)=LRTST
S FDA(3,LRFILE,LRIEN,1)=LROUTINE
;;*
S FDA(3,LRFILE,LRIEN,8.1)=LRTST
;;;*
D UPDATE^DIE("","FDA(3)","IEN","LRERR(3)")
I $D(LRERR(3)) D LRMSG("UPD68-3~LRAPLG1",.LRERR)
;
;
; Update #68 with specimen data
K LRFILE,FDAIEN,IEN
S LRFILE=68.05
; Check or Set top node for 68.05
S FDAIEN="?+"_LRCNT_","_LRAN_","_LRAD_","_LRAA_","
S FDA(31,LRFILE,FDAIEN,.01)=LRSPEC
S FDA(31,LRFILE,FDAIEN,1)=LRSAMP
D UPDATE^DIE("","FDA(31)","IEN","LRERR(31)")
I $D(LRERR(31)) D LRMSG("UPD68-31~LRAPLG1",.LRERR)
;
Q
;
;
UPD63 ; Update ORUT Node in #63
S LRTSORU=LRTST,LRURG=9,LRI=LRIDT
D SLRSS^LRWLST11
D ORUT^LRWLST11
;
;
Q
;
;
X ; from LRAUAW
I "CYEMSP"[LRSS K ^LR(LRXREF,LRH(2),LRABV,LRAN)
I LRSS="AU" D
. I $D(^LR(LRDFN,"AV")) K ^LR(LRDFN,"AV")
. I $D(^LR(LRDFN,"AW")) K ^LR(LRDFN,"AW")
. I $D(^LR(LRDFN,"AWI")) K ^LR(LRDFN,"AWI")
. I $D(LRRC) K ^LR("AAUA",+$E(LRRC,1,3),LRABV,LRAN),^LR("AAU",+LRRC,LRDFN)
I $G(LRRC)>1 K:LRSS?1(1"SP",1"CY",1"EM") ^LR(LRXR,LRRC,LRDFN,LRI)
K LRRC
Q
;
;
OS ; User choosing accession number
N DIR,DIROUT,DIRUT,DTOUT,LRSPEC,X,Y
S DIR(0)="N^1:999999:0^D OSDIR^LRAPLG1"
S DIR("A")="Enter Accession #"
D ^DIR
I $D(DIRUT) S LRFND=1 Q
S LRAN=Y
;
;Do not allow edits to accessions already on file.
;Otherwise, several orders will be created for the same order number
;and CPRS will not display the edited/updated information.
;
I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. W !!,?5,"This accession has already been logged in."
. W !,?5,"""Log-in menu, anat path"" should NOT be used to edit an accession."
. W !,?5,"Use ""Edit/modify data, anat path"" instead."
. S LRFND=1
;
I $D(LRXREF),$D(^LR(LRXREF,LRH(2),LRABV,LRAN)) D ^LRAPLG2 Q
;
D CRE868
I $D(LRMSG) S LRFND=1
Q
;
;
;
OSDIR ; Called from DIR call in OS above
;
;ZEXCEPT: LRAA,LRAD,LRDFN,X
;
; Accession number doesn't exist in file #68 - quit, OK to use this number
I $O(^LRO(68,LRAA,1,LRAD,1,+X,""))="" Q
;
N LRX
S LRX=$G(^LRO(68,LRAA,1,LRAD,1,+X,0))
I LRX<1 K X Q
;
; Stub entry which matches on LRDFN
I LRX=LRDFN Q
;
I $P(LRX,U)'=LRDFN S X=+X D ^LRUTELL K X
;
Q
;
;
ORDTST ; Prompt for ordered test(s); translate to NLT code for storage in ORUT
; Add NLT code to temp array LRXX (This code currently assumes one ordered test per accession)
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRNLT,LRWKCD,XX
S (LRNLT,LRWKCD)="",II=0
S DIR(0)="P^LAB(60,:AEMOQ",DIR("B")=$G(LRTST(0))
S DIR("S")="I $P(^LAB(60,Y,0),""^"",4)=LRSS,""IBO""[$P(^LAB(60,Y,0),""^"",3),$P($G(^LAB(60,Y,64)),""^"")"
D ^DIR
I $D(DIRUT) S II=2 Q
S LRWKCD=+$G(^LAB(60,+Y,64)),LRNLT=$P($G(^LAM(LRWKCD,0)),"^",2),II=1
S XX=0
F S XX=$O(LRXX(XX)) Q:'XX S $P(LRXX(XX),"^",2)=LRNLT_"^"_+Y
;
Q
;
;
GETSTCS ;Get spec top and coll samp
N LRI
K LRXX
S LRI=0,(LRXX,X)=""
F S LRI=$O(^LR(LRDFN,LRSS,LRIDT,.1,LRI)) Q:'LRI D
. S X=$G(^LR(LRDFN,LRSS,LRIDT,.1,LRI,0))
. I $P(X,"^",6)'="" S LRXX($P(X,"^",6))=$P(X,"^",7)_"^"
Q
;
;
CRE868 ; Create accession number in file 68
N LRFDA,LRFDAIEN,LRIEN
K LRMSG
S LRIEN="+1,"_LRAD_","_LRAA_","
S LRFDAIEN(1)=LRAN
S LRFDA(1,68.02,LRIEN,.01)=LRDFN
D UPDATE^DIE("S","LRFDA(1)","LRFDAIEN","LRMSG")
I $D(LRMSG) S LRSD=LRAD D LRMSG("EN~LRAPGL1",.LRMSG) Q
S X=LRAN
Q
;
;
CRE863 ; Create entry in file #63
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="DO^:NOW:ET"
S DIR("A")="Date/time Specimen taken",DIR("B")="NOW"
;;
I '$G(LRAPDIAL) D ^DIR K DIR I Y<1 D END Q
I $G(LRAPDIAL) S Y=LRCDT
;;;*
S (LRY,LRSD)=Y,LRI=9999999-LRY
;
; Process and get unique LRI
F Q:'$D(^LR(LRDFN,LRSS,LRI,0)) D
. S (LRSD,LRY)=$$FMADD^XLFDT(LRY,,,,1)
. S LRI=9999999-LRY
;
N LRFDA,LRIEN,LRFILE,LRFDAIEN
K DIERR,LRMSG
S LRACC=LRAC,LRNT=$$NOW^XLFDT()
S LRFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:63.08)
S LRFDAIEN(1)=LRI
S LRIEN="+1,"_LRDFN_","
S LRFDA(2,LRFILE,LRIEN,.01)=LRSD ;DATE/TIME SPECIMEN TAKEN
S LRFDA(2,LRFILE,LRIEN,.06)=LRACC
;;*
I $G(LRAPDIAL) D ; STORE ORDERING PROVIDER - LRAPDIAL SET IN LRAPKOE
. I $G(LRPHY) S LRFDA(2,LRFILE,LRIEN,.02)=+$G(LRPHY) ;Pathologist
. I $G(LRORPROV) S LRFDA(2,LRFILE,LRIEN,.07)=LRORPROV ; ORDERING PROVIDER
. I $G(LRLLOC)'="" S LRFDA(2,LRFILE,LRIEN,.08)=LRLLOC ; ORDER LOCATION
. I $G(LRSUBBY)'="" S LRFDA(2,LRFILE,LRIEN,.011)=LRSUBBY ; SUBMIT BY
. S LRFDA(2,LRFILE,LRIEN,.1)=LRNT ;DATE/TIME SPECIMEN RECIEVED
;;;*
;
D UPDATE^DIE("","LRFDA(2)","LRFDAIEN","LRMSG")
L -^LR(LRDFN,LRSS)
I $D(LRMSG) D LRMSG("F~LRAPLG1",.LRMSG) Q
;
S (LRI,LRIDT)=LRFDAIEN(1)
;
Q
;
;
SPMOVE ; Copy surgery information into lab package
; - store surgery package reference to retrieve surgeon/attending.
; - LRFLAG used to determine if data copied from Surgery packge and moved to Lab and generate notice.
; if no data before and data after call to SROSPLG then add disclaimer.
;
S X="SROSPLG" X ^%ZOSF("TEST")
I '$T Q
;
N I,LRFIELD,LRFLAG,LRJ,LRSREF,LRSRTN,LRWP
S LRFLAG="",LRSRTN=$G(SRTN)
I LRSRTN D
. N LRDATA,LRDIE
. S LRDATA(.01)=LRDFN_","_LRSS_","_LRI_",0"
. S LRDATA(.02)=1
. S LRDATA(1)=LRSRTN_";SRF("
. D SETREF^LRUEPR(LRDFN,LRDATA(.01),.LRDATA,1)
. F I=.2,.3,.4,.5 I '$O(^LR(LRDFN,LRSS,LRI,I,0)) S $P(LRFLAG,"^",I*10)=1
;
D DISP^SROSPLG
;
; Create notation on where info came from if site wants reference.
; also store referece as external package reference.
S LRSREF=$$GET^XPAR("DIV^PKG","LR AP SURGERY REFERENCE",1,"Q")
S LRFIELD(.013)="(#60) BRIEF CLIN HISTORY"
S LRFIELD(.014)="(#32) PRINCIPAL PRE-OP DIAGNOSIS, (#.72) OTHER PREOP DIAGNOSIS"
S LRFIELD(.015)="(#59) OPERATIVE FINDINGS"
S LRFIELD(.016)="(#34) PRINCIPAL POST-OP DIAG, (#.74) OTHER POSTOP DIAGS"
S LRWP(1)=" "
F LRJ=.2,.3,.4,.5 I $P(LRFLAG,"^",LRJ*10),$O(^LR(LRDFN,LRSS,LRI,LRJ,0)) D
. N LRDATA,LRDIE
. S LRFIELD=$P("^.013^.014^.015^.016","^",LRJ*10)
. S LRWP(2)="Information automatically documented from SURGERY package case #"_LRSRTN_" Field "_LRFIELD(LRFIELD)
. I LRSREF=1 D WP^DIE(63.08,LRI_","_LRDFN_",",LRFIELD,"A","LRWP","LRDIE(LRFIELD)")
. S LRDATA(.01)=LRDFN_","_LRSS_","_LRI_","_LRJ_",0"
. S LRDATA(.02)=1
. S LRDATA(1)=LRSRTN_";SRF(;"_LRWP(2)
. D SETREF^LRUEPR(LRDFN,LRDATA(.01),.LRDATA,1)
;
Q
;
;
LRMSG(LRRNAME,LRFMERR) ;
; Filing error notification
; Inputs
; LRRNAME: Routine name (TAG~RTN)
; LRFMERR:<byref> FileMan error local array
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRDIE
S LRRNAME=$TR($G(LRRNAME),"^","~")
M LRDIE=LRFMERR
D MAILALRT^LRWLST12(LRRNAME,.LRFMERR)
S DIR(0)="EA"
S DIR("A",1)="Filing error in "_LRRNAME_" for this accession/specimen"
S DIR("A")="Press the return key to continue"
D ^DIR
Q
;
;
OUT ;
; Exit point
Q
;
;
END ; from LRAUAW, LRAPLG2
; Lock Accession file
D LOCK^DILF("^LRO(68,LRAA,1,LRAD,1,0)")
I '$T D EN^DDIOL("Someone else is logging in specimens. Please wait and try again.","","!!") Q
;
N DIK,DA
S DA=LRAN,DA(1)=LRAD,DA(2)=LRAA
S DIK="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,"
D ^DIK
;
L -^LRO(68,LRAA,1,LRAD,1,0)
Q
;
;
FIX ; Entry point to delete an orphan AP entry in file #63
;
N DA,DFN,DIC,DIK,DIR,DIROUT,DIRUT,DIQ,DR,DTOUT
N LRAA,LRABV,LRAC,LRAD,LRAN,LRDFN,LRDPA,LRDPF,LRH,LRI,LRRC,LRSS,LRWHN,LRXR,LRXREF
N AGE,PNM,SEX,X,Y
;
D ^LRAP Q:'$D(Y)
D XR^LRU
;
I LRSS'?1(1"SP",1"CY",1"EM") W !,"This program only supports SP, CY and EM subscripts",! Q
;
S LRH(2)=$E(LRAD,1,3),LRWHN=$E(LRAD,2,3)
;
D EN1^LRUPS Q:LRAN=-1
I $P(^LR(LRDFN,LRSS,LRI,0),"^",11)'="" W !,"Report has been released!",! Q
I $D(^LR(LRDFN,LRSS,LRI,2005)) D Q
. W !,"Report has associated images in IMAGING package!"
. W !,"Disposition these images before deleting this entry!",!
;
K DR
S DIC="^LR("_LRDFN_","""_LRSS_""",",DA(1)=LRDFN,DA=LRI,DIQ(0)="ACR"
D EN^DIQ
;
S DIR(0)="Y",DIR("A")="DELETE this entry",DIR("B")="NO"
D ^DIR
I Y<1 Q
;
K DIR
S DIR(0)="Y",DIR("A")="Are you sure",DIR("B")="NO"
D ^DIR
I Y<1 Q
;
; Lock record
D LOCK^DILF("^LR(LRDFN,LRSS,LRI)")
I '$T D Q
. D EN^DDIOL("Someone else is accessing this record. Please wait and try again.","","!!")
. D KVA^VADPT,V^LRU
;
K DA,DIK
S DA=LRI,DA(1)=LRDFN,DIK="^LR("_DA(1)_","""_LRSS_""","
D ^DIK
;
; Cleanup some cross-references.
I LRSS?1(1"SP",1"CY",1"EM") D
. K ^LR(LRXREF,LRH(2),LRABV,LRAN,LRDFN,LRI)
. I $G(LRRC)>1 K ^LR(LRXR,LRRC,LRDFN,LRI)
;
I LRSS="AU" D
. I $D(^LR(LRDFN,"AV")) K ^LR(LRDFN,"AV")
. I $D(^LR(LRDFN,"AW")) K ^LR(LRDFN,"AW")
. I $D(^LR(LRDFN,"AWI")) K ^LR(LRDFN,"AWI")
. I $D(LRRC) K ^LR("AAUA",+$E(LRRC,1,3),LRABV,LRAN),^LR("AAU",+LRRC,LRDFN)
;
; Release lock
L -^LR(LRDFN,LRSS,LRI)
;
W !!,"Entry deleted",!
D KVA^VADPT,V^LRU
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPLG1 14517 printed Dec 13, 2024@02:07:38 Page 2
LRAPLG1 ;DALOI/CKA,JMC,PMK - LOG-IN CONT. ;02/17/17 13:42
+1 ;;5.2;LAB SERVICE;**72,121,248,308,350,427,433,462,479,485**;Sep 27, 1994;Build 1
+2 ;
+3 ; Reference to DISP^SROSPLG supported by IA #893
+4 ;
START ; Start logging in the specimens.
+1 NEW LRFND,LRMSG,LRXX
+2 ;
+3 ; Lock ^LR( and ^LRO
+4 DO LOCK^DILF("^LR(LRDFN,LRSS)")
+5 IF '$TEST
Begin DoDot:1
+6 SET LRMSG="This record is locked by another user. Please try later."
+7 DO EN^DDIOL(LRMSG,"","!!")
End DoDot:1
QUIT
+8 ;
+9 DO LOCK^DILF("^LRO(68,LRAA,1,LRAD,1,0)")
+10 IF '$TEST
Begin DoDot:1
+11 LOCK -^LR(LRDFN,LRSS)
+12 SET LRMSG="Someone else is logging in specimens. Please wait and try again."
+13 DO EN^DDIOL(LRMSG,"","!!")
End DoDot:1
QUIT
+14 ;
+15 ; Check that accession date exists first
+16 DO CHECK68^LRWLST1(LRAA,LRAD)
+17 ;
EN ;
+1 NEW LRAPDAN
+2 ;
+3 SET (LRI,LRIDT)=""
+4 SET LRAN=1
+5 SET LRAPDAN=$$GET^XPAR("ALL","LR AP DEFAULT ACCESSION NUMBER","`"_LRAA,"Q")
+6 IF LRAPDAN=2
SET LRAN=+$PIECE(^LRO(68,LRAA,1,LRAD,1,0),U,3)
+7 FOR
if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))
QUIT
SET LRAN=LRAN+1
+8 WRITE !!,"Assign ",LRO(68)," (",LRABV,") accession #: ",LRAN
SET %=1
DO YN^LRU
+9 IF %<1
LOCK -^LRO(68,LRAA,1,LRAD,1,0),-^LR(LRDFN,LRSS)
QUIT
+10 ;
+11 IF %=1
IF $DATA(LRXREF)
IF $DATA(^LR(LRXREF,LRH(2),LRABV,LRAN))
Begin DoDot:1
+12 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
IF $PIECE(^(0),U)
SET X=LRAN
DO ^LRUTELL
SET LRFND=1
+13 IF '$DATA(LRFND)
DO ^LRAPLG2
+14 IF $DATA(LRFND)
LOCK -^LRO(68,LRAA,1,LRAD,1,0),-^LR(LRDFN,LRSS)
QUIT
+15 SET %=0
End DoDot:1
if $DATA(LRFND)
QUIT
+16 ;
+17 IF %=1
DO CRE868
IF $DATA(LRMSG)
GOTO EN
+18 ;
+19 IF %=2
DO OS
IF $DATA(LRFND)
KILL LRFND
LOCK -^LRO(68,LRAA,1,LRAD,1,0),-^LR(LRDFN,LRSS)
QUIT
+20 ;
+21 LOCK -^LRO(68,LRAA,1,LRAD,1,0)
+22 ;
+23 SET LRAC=$PIECE(^LRO(68,LRAA,0),U,11)_" "_$SELECT(LRAD["0000":$EXTRACT(LRAD,2,3),1:$EXTRACT(LRAD,4,7))_" "_LRAN
+24 ;
AU ; Autopsy Specific
+1 IF LRSS="AU"
DO ^LRAUAW
QUIT
+2 if '$DATA(^LR(LRDFN,LRSS,0))
SET ^(0)="^"_LRSF_"DA^0^0"
+3 ;
+4 ; If orginal login then create entry in file #63
LR7OFA0 ;
+1 IF LRIDT=""
DO CRE863
+2 IF LRI=""
QUIT
+3 ;
+4 KILL DA,DTOUT,DIWESUB
+5 ;S DIWESUB=$E(PNM,1,27-$L(LRACC))_" ["_LRACC_"]"
+6 SET LR(.07)=$SELECT($DATA(SRDOC):SRDOC,1:"")
KILL SRDOC
+7 if LR(.07)
SET LR(.07)=$PIECE($GET(^VA(200,LR(.07),0)),"^")
+8 SET DA=LRI
SET DA(1)=LRDFN
+9 SET DIC(0)="EQLMF"
SET DLAYGO=63
SET DIE="^LR(LRDFN,LRSS,"
+10 DO @LR("L")
+11 DO ^DIE
KILL DLAYGO
+12 if '$DATA(LRRC)
SET LRRC=LRNT
+13 ;
+14 ; Check if topography and collection sample entered on each specimen.
+15 ; If not entered then define Y to cause entry to be deleted.
+16 IF LRSS?1(1"SP",1"CY",1"EM")
Begin DoDot:1
+17 NEW I,LRJ,X
+18 SET LRJ=0
+19 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSS,LRI,.1,LRJ))
if LRJ<1
QUIT
Begin DoDot:2
+20 SET X=$GET(^LR(LRDFN,LRSS,LRI,.1,LRJ,0))
+21 FOR I=6,7
IF $PIECE(X,"^",I)=""
SET Y=""
QUIT
End DoDot:2
if $DATA(Y)
QUIT
End DoDot:1
+22 ;
+23 ; Delete entry if prompts not answered unless report has been released.
+24 IF $DATA(DTOUT)!$DATA(Y)
Begin DoDot:1
+25 NEW DA,DIK
+26 IF LRSS?1(1"SP",1"CY",1"EM")
IF ($PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)!$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",15))
QUIT
+27 WRITE $CHAR(7),!!,"All Prompts not answered - <ENTRY DELETED>"
+28 SET DA(1)=LRDFN
SET DA=LRI
+29 SET DIK="^LR("_DA(1)_","""_LRSS_""","
+30 DO ^DIK
DO X
DO END
End DoDot:1
QUIT
+31 ;
+32 ; Store specimen topography, coll sample in temp array
DO GETSTCS
+33 ;
TST ; Get the ordered test and store in temp array
+1 NEW II
+2 DO ORDTST
+3 ; Delete entry if no ordered tests unless report has been released.
+4 IF II=2
Begin DoDot:1
+5 IF LRSS?1(1"SP",1"CY",1"EM")
IF ($PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)!$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",15))
QUIT
+6 NEW DA,DIK
+7 WRITE $CHAR(7),!!,"No ordered test selected - <ENTRY DELETED>"
+8 SET DA(1)=LRDFN
SET DA=LRI
SET DIK="^LR("_DA(1)_","""_LRSS_""","
+9 DO ^DIK
DO X
DO END
End DoDot:1
QUIT
+10 ;
+11 IF LRSS="CY"
IF LRCAPA
DO CK^LRAPCWK
+12 ;
+13 ; Check for surgery case references and move info if user wants surgical case info copied to Lab.
+14 IF LRSS="SP"
DO SPMOVE
+15 ;
+16 ; Fill out the stub accession with related info
+17 IF '$DATA(LRC(5))
SET LRC(5)=""
+18 DO ^LRUWLF
+19 ;
+20 IF LRCAPA
Begin DoDot:1
+21 IF LRSS="CY"
DO ^LRAPCWK
+22 IF LRSS?1(1"SP",1"EM")
DO ^LRAPSWK
End DoDot:1
+23 ;
+24 IF LRSS?1(1"SP",1"CY",1"EM")
DO ^LRSPGD
+25 ;
+26 ; add case to file #2005.42 - P433
IF $TEXT(ADD^MAGTP005)'=""
NEW MAGNEWCASE
SET MAGNEWCASE=1
DO ADD^MAGTP005(LRAC)
+27 ;
+28 DO OERR^LR7OB63D
DO LDSI
+29 ;
+30 ; invoke Imaging HL7 routine - P433
IF $TEXT(NEW^MAGT7MA)'=""
DO NEW^MAGT7MA
+31 ;
+32 QUIT
+33 ;
+34 ;
LDSI ; LDSI tasks
+1 ;
+2 NEW LRLLOC,LRALOC,LRPRAC,LROUTINE,LROPL,LRODT,LRNT,LRFILE,LRIENS,LRORD,LRSRDT,LRTST
+3 ;
+4 ; Get variables for ORUT node
+5 ;default urgency
SET LROUTINE=$PIECE($GET(^LAB(69.9,1,3)),"^",2)
+6 ;Ordering provider-CKA
SET LRPROVL=LRMD(1)
+7 ; Get ORDER TYPE
+8 ;;*
+9 ;Default to 'Ward Collect' for now
if $GET(LRORDR)=""
SET LRORDR="WC"
+10 ;;;*
+11 ;Date ordered = current date/time
SET LRNT=$$NOW^XLFDT()
+12 SET LRODT=$PIECE(LRNT,".")
+13 ; Get Provider, Location abbrev, Collection date/time
+14 SET LRFILE=$SELECT(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
+15 SET LRIENS=LRI_","_LRDFN_","
+16 SET LRPRAC=$$GET1^DIQ(LRFILE,LRIENS,.07,"I")
+17 SET LRLLOC=$$GET1^DIQ(LRFILE,LRIENS,.08,"I")
+18 IF LRLLOC=""
SET LRLLOC="NO ABRV"
+19 SET LRSDT=+$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
+20 ; Specimen received date/time
SET LRSRDT=$$GET1^DIQ(LRFILE,LRIENS,.1,"I")
+21 ; Get CPRS Order #
+22 ; Default to blank for now
SET ORIFN=""
+23 ;
+24 ; Get Lab Order #, update file #69 and #68
LDSI1 SET (LRORD,LRSPEC,LRTST,LRSAMP,LRADD,LROT)=""
SET LRCNT=1
+1 FOR
SET LRSPEC=$ORDER(LRXX(LRSPEC))
if 'LRSPEC
QUIT
Begin DoDot:1
+2 NEW LRRECINF
+3 SET LRSAMP=$PIECE(LRXX(LRSPEC),"^",1)
SET LRNLT=$PIECE(LRXX(LRSPEC),"^",2)
SET LRTST=$PIECE(LRXX(LRSPEC),"^",3)
+4 if 'LRTST
QUIT
+5 ;I LRORD,$G(^LAB(69.9,1,21661)) S LRADD=1 D ZSN^LR7OFAO("",.LRRECINF)
+6 ; Get Lab Order # first time thru
+7 if 'LRORD
DO EN^LR7OFAO(LRODT,LRDFN,LRSAMP,LRORDR,LRNT,LRPRAC,LRLLOC,LRSDT,ORIFN,LRSPEC,LRSS,LRTST,LRUID,.LRRECINF)
+8 SET LRSN=+$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)
SET LRCDT=0
SET LREAL=""
+9 IF LRSN>0
SET LRCDT=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",1,2)
SET LREAL=$PIECE(LRCDT,"^",2)
SET LRCDT=+LRCDT
+10 DO UPD68
DO UPD63
+11 SET LRCNT=LRCNT+1
End DoDot:1
+12 ;
+13 QUIT
+14 ;
+15 ;
UPD68 ; Update #68 with required test data
+1 NEW LRFILE,LRERR,IEN,LRIEN
+2 SET LRFILE=68.04
SET IEN(1)=LRTST
+3 SET LRIEN="?+1,"_LRAN_","_LRAD_","_LRAA_","
+4 SET FDA(3,LRFILE,LRIEN,.01)=LRTST
+5 SET FDA(3,LRFILE,LRIEN,1)=LROUTINE
+6 ;;*
+7 SET FDA(3,LRFILE,LRIEN,8.1)=LRTST
+8 ;;;*
+9 DO UPDATE^DIE("","FDA(3)","IEN","LRERR(3)")
+10 IF $DATA(LRERR(3))
DO LRMSG("UPD68-3~LRAPLG1",.LRERR)
+11 ;
+12 ;
+13 ; Update #68 with specimen data
+14 KILL LRFILE,FDAIEN,IEN
+15 SET LRFILE=68.05
+16 ; Check or Set top node for 68.05
+17 SET FDAIEN="?+"_LRCNT_","_LRAN_","_LRAD_","_LRAA_","
+18 SET FDA(31,LRFILE,FDAIEN,.01)=LRSPEC
+19 SET FDA(31,LRFILE,FDAIEN,1)=LRSAMP
+20 DO UPDATE^DIE("","FDA(31)","IEN","LRERR(31)")
+21 IF $DATA(LRERR(31))
DO LRMSG("UPD68-31~LRAPLG1",.LRERR)
+22 ;
+23 QUIT
+24 ;
+25 ;
UPD63 ; Update ORUT Node in #63
+1 SET LRTSORU=LRTST
SET LRURG=9
SET LRI=LRIDT
+2 DO SLRSS^LRWLST11
+3 DO ORUT^LRWLST11
+4 ;
+5 ;
+6 QUIT
+7 ;
+8 ;
X ; from LRAUAW
+1 IF "CYEMSP"[LRSS
KILL ^LR(LRXREF,LRH(2),LRABV,LRAN)
+2 IF LRSS="AU"
Begin DoDot:1
+3 IF $DATA(^LR(LRDFN,"AV"))
KILL ^LR(LRDFN,"AV")
+4 IF $DATA(^LR(LRDFN,"AW"))
KILL ^LR(LRDFN,"AW")
+5 IF $DATA(^LR(LRDFN,"AWI"))
KILL ^LR(LRDFN,"AWI")
+6 IF $DATA(LRRC)
KILL ^LR("AAUA",+$EXTRACT(LRRC,1,3),LRABV,LRAN),^LR("AAU",+LRRC,LRDFN)
End DoDot:1
+7 IF $GET(LRRC)>1
if LRSS?1(1"SP",1"CY",1"EM")
KILL ^LR(LRXR,LRRC,LRDFN,LRI)
+8 KILL LRRC
+9 QUIT
+10 ;
+11 ;
OS ; User choosing accession number
+1 NEW DIR,DIROUT,DIRUT,DTOUT,LRSPEC,X,Y
+2 SET DIR(0)="N^1:999999:0^D OSDIR^LRAPLG1"
+3 SET DIR("A")="Enter Accession #"
+4 DO ^DIR
+5 IF $DATA(DIRUT)
SET LRFND=1
QUIT
+6 SET LRAN=Y
+7 ;
+8 ;Do not allow edits to accessions already on file.
+9 ;Otherwise, several orders will be created for the same order number
+10 ;and CPRS will not display the edited/updated information.
+11 ;
+12 IF $GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+13 WRITE !!,?5,"This accession has already been logged in."
+14 WRITE !,?5,"""Log-in menu, anat path"" should NOT be used to edit an accession."
+15 WRITE !,?5,"Use ""Edit/modify data, anat path"" instead."
+16 SET LRFND=1
End DoDot:1
QUIT
+17 ;
+18 IF $DATA(LRXREF)
IF $DATA(^LR(LRXREF,LRH(2),LRABV,LRAN))
DO ^LRAPLG2
QUIT
+19 ;
+20 DO CRE868
+21 IF $DATA(LRMSG)
SET LRFND=1
+22 QUIT
+23 ;
+24 ;
+25 ;
OSDIR ; Called from DIR call in OS above
+1 ;
+2 ;ZEXCEPT: LRAA,LRAD,LRDFN,X
+3 ;
+4 ; Accession number doesn't exist in file #68 - quit, OK to use this number
+5 IF $ORDER(^LRO(68,LRAA,1,LRAD,1,+X,""))=""
QUIT
+6 ;
+7 NEW LRX
+8 SET LRX=$GET(^LRO(68,LRAA,1,LRAD,1,+X,0))
+9 IF LRX<1
KILL X
QUIT
+10 ;
+11 ; Stub entry which matches on LRDFN
+12 IF LRX=LRDFN
QUIT
+13 ;
+14 IF $PIECE(LRX,U)'=LRDFN
SET X=+X
DO ^LRUTELL
KILL X
+15 ;
+16 QUIT
+17 ;
+18 ;
ORDTST ; Prompt for ordered test(s); translate to NLT code for storage in ORUT
+1 ; Add NLT code to temp array LRXX (This code currently assumes one ordered test per accession)
+2 ;
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRNLT,LRWKCD,XX
+4 SET (LRNLT,LRWKCD)=""
SET II=0
+5 SET DIR(0)="P^LAB(60,:AEMOQ"
SET DIR("B")=$GET(LRTST(0))
+6 SET DIR("S")="I $P(^LAB(60,Y,0),""^"",4)=LRSS,""IBO""[$P(^LAB(60,Y,0),""^"",3),$P($G(^LAB(60,Y,64)),""^"")"
+7 DO ^DIR
+8 IF $DATA(DIRUT)
SET II=2
QUIT
+9 SET LRWKCD=+$GET(^LAB(60,+Y,64))
SET LRNLT=$PIECE($GET(^LAM(LRWKCD,0)),"^",2)
SET II=1
+10 SET XX=0
+11 FOR
SET XX=$ORDER(LRXX(XX))
if 'XX
QUIT
SET $PIECE(LRXX(XX),"^",2)=LRNLT_"^"_+Y
+12 ;
+13 QUIT
+14 ;
+15 ;
GETSTCS ;Get spec top and coll samp
+1 NEW LRI
+2 KILL LRXX
+3 SET LRI=0
SET (LRXX,X)=""
+4 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRIDT,.1,LRI))
if 'LRI
QUIT
Begin DoDot:1
+5 SET X=$GET(^LR(LRDFN,LRSS,LRIDT,.1,LRI,0))
+6 IF $PIECE(X,"^",6)'=""
SET LRXX($PIECE(X,"^",6))=$PIECE(X,"^",7)_"^"
End DoDot:1
+7 QUIT
+8 ;
+9 ;
CRE868 ; Create accession number in file 68
+1 NEW LRFDA,LRFDAIEN,LRIEN
+2 KILL LRMSG
+3 SET LRIEN="+1,"_LRAD_","_LRAA_","
+4 SET LRFDAIEN(1)=LRAN
+5 SET LRFDA(1,68.02,LRIEN,.01)=LRDFN
+6 DO UPDATE^DIE("S","LRFDA(1)","LRFDAIEN","LRMSG")
+7 IF $DATA(LRMSG)
SET LRSD=LRAD
DO LRMSG("EN~LRAPGL1",.LRMSG)
QUIT
+8 SET X=LRAN
+9 QUIT
+10 ;
+11 ;
CRE863 ; Create entry in file #63
+1 ;
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="DO^:NOW:ET"
+4 SET DIR("A")="Date/time Specimen taken"
SET DIR("B")="NOW"
+5 ;;
+6 IF '$GET(LRAPDIAL)
DO ^DIR
KILL DIR
IF Y<1
DO END
QUIT
+7 IF $GET(LRAPDIAL)
SET Y=LRCDT
+8 ;;;*
+9 SET (LRY,LRSD)=Y
SET LRI=9999999-LRY
+10 ;
+11 ; Process and get unique LRI
+12 FOR
if '$DATA(^LR(LRDFN,LRSS,LRI,0))
QUIT
Begin DoDot:1
+13 SET (LRSD,LRY)=$$FMADD^XLFDT(LRY,,,,1)
+14 SET LRI=9999999-LRY
End DoDot:1
+15 ;
+16 NEW LRFDA,LRIEN,LRFILE,LRFDAIEN
+17 KILL DIERR,LRMSG
+18 SET LRACC=LRAC
SET LRNT=$$NOW^XLFDT()
+19 SET LRFILE=$SELECT(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:63.08)
+20 SET LRFDAIEN(1)=LRI
+21 SET LRIEN="+1,"_LRDFN_","
+22 ;DATE/TIME SPECIMEN TAKEN
SET LRFDA(2,LRFILE,LRIEN,.01)=LRSD
+23 SET LRFDA(2,LRFILE,LRIEN,.06)=LRACC
+24 ;;*
+25 ; STORE ORDERING PROVIDER - LRAPDIAL SET IN LRAPKOE
IF $GET(LRAPDIAL)
Begin DoDot:1
+26 ;Pathologist
IF $GET(LRPHY)
SET LRFDA(2,LRFILE,LRIEN,.02)=+$GET(LRPHY)
+27 ; ORDERING PROVIDER
IF $GET(LRORPROV)
SET LRFDA(2,LRFILE,LRIEN,.07)=LRORPROV
+28 ; ORDER LOCATION
IF $GET(LRLLOC)'=""
SET LRFDA(2,LRFILE,LRIEN,.08)=LRLLOC
+29 ; SUBMIT BY
IF $GET(LRSUBBY)'=""
SET LRFDA(2,LRFILE,LRIEN,.011)=LRSUBBY
+30 ;DATE/TIME SPECIMEN RECIEVED
SET LRFDA(2,LRFILE,LRIEN,.1)=LRNT
End DoDot:1
+31 ;;;*
+32 ;
+33 DO UPDATE^DIE("","LRFDA(2)","LRFDAIEN","LRMSG")
+34 LOCK -^LR(LRDFN,LRSS)
+35 IF $DATA(LRMSG)
DO LRMSG("F~LRAPLG1",.LRMSG)
QUIT
+36 ;
+37 SET (LRI,LRIDT)=LRFDAIEN(1)
+38 ;
+39 QUIT
+40 ;
+41 ;
SPMOVE ; Copy surgery information into lab package
+1 ; - store surgery package reference to retrieve surgeon/attending.
+2 ; - LRFLAG used to determine if data copied from Surgery packge and moved to Lab and generate notice.
+3 ; if no data before and data after call to SROSPLG then add disclaimer.
+4 ;
+5 SET X="SROSPLG"
XECUTE ^%ZOSF("TEST")
+6 IF '$TEST
QUIT
+7 ;
+8 NEW I,LRFIELD,LRFLAG,LRJ,LRSREF,LRSRTN,LRWP
+9 SET LRFLAG=""
SET LRSRTN=$GET(SRTN)
+10 IF LRSRTN
Begin DoDot:1
+11 NEW LRDATA,LRDIE
+12 SET LRDATA(.01)=LRDFN_","_LRSS_","_LRI_",0"
+13 SET LRDATA(.02)=1
+14 SET LRDATA(1)=LRSRTN_";SRF("
+15 DO SETREF^LRUEPR(LRDFN,LRDATA(.01),.LRDATA,1)
+16 FOR I=.2,.3,.4,.5
IF '$ORDER(^LR(LRDFN,LRSS,LRI,I,0))
SET $PIECE(LRFLAG,"^",I*10)=1
End DoDot:1
+17 ;
+18 DO DISP^SROSPLG
+19 ;
+20 ; Create notation on where info came from if site wants reference.
+21 ; also store referece as external package reference.
+22 SET LRSREF=$$GET^XPAR("DIV^PKG","LR AP SURGERY REFERENCE",1,"Q")
+23 SET LRFIELD(.013)="(#60) BRIEF CLIN HISTORY"
+24 SET LRFIELD(.014)="(#32) PRINCIPAL PRE-OP DIAGNOSIS, (#.72) OTHER PREOP DIAGNOSIS"
+25 SET LRFIELD(.015)="(#59) OPERATIVE FINDINGS"
+26 SET LRFIELD(.016)="(#34) PRINCIPAL POST-OP DIAG, (#.74) OTHER POSTOP DIAGS"
+27 SET LRWP(1)=" "
+28 FOR LRJ=.2,.3,.4,.5
IF $PIECE(LRFLAG,"^",LRJ*10)
IF $ORDER(^LR(LRDFN,LRSS,LRI,LRJ,0))
Begin DoDot:1
+29 NEW LRDATA,LRDIE
+30 SET LRFIELD=$PIECE("^.013^.014^.015^.016","^",LRJ*10)
+31 SET LRWP(2)="Information automatically documented from SURGERY package case #"_LRSRTN_" Field "_LRFIELD(LRFIELD)
+32 IF LRSREF=1
DO WP^DIE(63.08,LRI_","_LRDFN_",",LRFIELD,"A","LRWP","LRDIE(LRFIELD)")
+33 SET LRDATA(.01)=LRDFN_","_LRSS_","_LRI_","_LRJ_",0"
+34 SET LRDATA(.02)=1
+35 SET LRDATA(1)=LRSRTN_";SRF(;"_LRWP(2)
+36 DO SETREF^LRUEPR(LRDFN,LRDATA(.01),.LRDATA,1)
End DoDot:1
+37 ;
+38 QUIT
+39 ;
+40 ;
LRMSG(LRRNAME,LRFMERR) ;
+1 ; Filing error notification
+2 ; Inputs
+3 ; LRRNAME: Routine name (TAG~RTN)
+4 ; LRFMERR:<byref> FileMan error local array
+5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRDIE
+6 SET LRRNAME=$TRANSLATE($GET(LRRNAME),"^","~")
+7 MERGE LRDIE=LRFMERR
+8 DO MAILALRT^LRWLST12(LRRNAME,.LRFMERR)
+9 SET DIR(0)="EA"
+10 SET DIR("A",1)="Filing error in "_LRRNAME_" for this accession/specimen"
+11 SET DIR("A")="Press the return key to continue"
+12 DO ^DIR
+13 QUIT
+14 ;
+15 ;
OUT ;
+1 ; Exit point
+2 QUIT
+3 ;
+4 ;
END ; from LRAUAW, LRAPLG2
+1 ; Lock Accession file
+2 DO LOCK^DILF("^LRO(68,LRAA,1,LRAD,1,0)")
+3 IF '$TEST
DO EN^DDIOL("Someone else is logging in specimens. Please wait and try again.","","!!")
QUIT
+4 ;
+5 NEW DIK,DA
+6 SET DA=LRAN
SET DA(1)=LRAD
SET DA(2)=LRAA
+7 SET DIK="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,"
+8 DO ^DIK
+9 ;
+10 LOCK -^LRO(68,LRAA,1,LRAD,1,0)
+11 QUIT
+12 ;
+13 ;
FIX ; Entry point to delete an orphan AP entry in file #63
+1 ;
+2 NEW DA,DFN,DIC,DIK,DIR,DIROUT,DIRUT,DIQ,DR,DTOUT
+3 NEW LRAA,LRABV,LRAC,LRAD,LRAN,LRDFN,LRDPA,LRDPF,LRH,LRI,LRRC,LRSS,LRWHN,LRXR,LRXREF
+4 NEW AGE,PNM,SEX,X,Y
+5 ;
+6 DO ^LRAP
if '$DATA(Y)
QUIT
+7 DO XR^LRU
+8 ;
+9 IF LRSS'?1(1"SP",1"CY",1"EM")
WRITE !,"This program only supports SP, CY and EM subscripts",!
QUIT
+10 ;
+11 SET LRH(2)=$EXTRACT(LRAD,1,3)
SET LRWHN=$EXTRACT(LRAD,2,3)
+12 ;
+13 DO EN1^LRUPS
if LRAN=-1
QUIT
+14 IF $PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)'=""
WRITE !,"Report has been released!",!
QUIT
+15 IF $DATA(^LR(LRDFN,LRSS,LRI,2005))
Begin DoDot:1
+16 WRITE !,"Report has associated images in IMAGING package!"
+17 WRITE !,"Disposition these images before deleting this entry!",!
End DoDot:1
QUIT
+18 ;
+19 KILL DR
+20 SET DIC="^LR("_LRDFN_","""_LRSS_""","
SET DA(1)=LRDFN
SET DA=LRI
SET DIQ(0)="ACR"
+21 DO EN^DIQ
+22 ;
+23 SET DIR(0)="Y"
SET DIR("A")="DELETE this entry"
SET DIR("B")="NO"
+24 DO ^DIR
+25 IF Y<1
QUIT
+26 ;
+27 KILL DIR
+28 SET DIR(0)="Y"
SET DIR("A")="Are you sure"
SET DIR("B")="NO"
+29 DO ^DIR
+30 IF Y<1
QUIT
+31 ;
+32 ; Lock record
+33 DO LOCK^DILF("^LR(LRDFN,LRSS,LRI)")
+34 IF '$TEST
Begin DoDot:1
+35 DO EN^DDIOL("Someone else is accessing this record. Please wait and try again.","","!!")
+36 DO KVA^VADPT
DO V^LRU
End DoDot:1
QUIT
+37 ;
+38 KILL DA,DIK
+39 SET DA=LRI
SET DA(1)=LRDFN
SET DIK="^LR("_DA(1)_","""_LRSS_""","
+40 DO ^DIK
+41 ;
+42 ; Cleanup some cross-references.
+43 IF LRSS?1(1"SP",1"CY",1"EM")
Begin DoDot:1
+44 KILL ^LR(LRXREF,LRH(2),LRABV,LRAN,LRDFN,LRI)
+45 IF $GET(LRRC)>1
KILL ^LR(LRXR,LRRC,LRDFN,LRI)
End DoDot:1
+46 ;
+47 IF LRSS="AU"
Begin DoDot:1
+48 IF $DATA(^LR(LRDFN,"AV"))
KILL ^LR(LRDFN,"AV")
+49 IF $DATA(^LR(LRDFN,"AW"))
KILL ^LR(LRDFN,"AW")
+50 IF $DATA(^LR(LRDFN,"AWI"))
KILL ^LR(LRDFN,"AWI")
+51 IF $DATA(LRRC)
KILL ^LR("AAUA",+$EXTRACT(LRRC,1,3),LRABV,LRAN),^LR("AAU",+LRRC,LRDFN)
End DoDot:1
+52 ;
+53 ; Release lock
+54 LOCK -^LR(LRDFN,LRSS,LRI)
+55 ;
+56 WRITE !!,"Entry deleted",!
+57 DO KVA^VADPT
DO V^LRU
+58 ;
+59 QUIT
