LRAPKOE ;DSS/FHS - CRPS AP LAB ORDER ENTRY AND ACCESSION ;Jun 21, 2022@15:03:04
;;5.2;LAB SERVICE;**462,479,483,509,553**;Sep 27, 1994;Build 21
; Supported calls AI #, 5286,103,3615
EN1 ;
; Called from EN^LRAPLG
; Process CPRS AP Orders
N ANS,ANSY,CNT,CONTROL,DA,DIC,DIERR,DIR,DIRUT,DOD,DR
N DTOUT,DUOUT,ERR,FDA,FDAIEN,FIL,FLD,GOT,IEN,IENX,II
N LR,LRAA,LRACN,LRACN0,LRAP690,LRAPNT,LRAPSPEC
N LRAPTST,LRC,LRCAPA,LRCAPLOC,LRCHK
N LRCOL,LRCOM,LRC5,LRDFN,LRDISC,LRDIE,LRDOC,LRDPF,LREND,LRFDA
N LRFDAIEN,LRI,LRIDT,LRIEN,LRJ,LRLL,LRLLOC,LRLWC,LRMD,LRMSG
N LRNATURE,LRNLT,LRNODE69,LRNONE,LROD0,LROD1,LROD3,LRODT,LRODT0
N LROESTAT,LROLLOC,LRORD,LRORDRR,LROOS,LRORD,LRORDRR
N LRORIFN,LRORNUM,LRORPOV,LRORTYP,LRORU3,LROS,LROSD,LRPRAC,LRPANEL,LRPHY,LRPL
N LRPROVL,LRRC,LRROD,LRSAMP,LRSD,LRSIT,LRSN,LRSND
N LRSP,LRSPCOM,LRSPEC,LRSS,LRSTATUS,LRSUBBY,LRSUBMIT
N LRSVSN,LRT,LRTM7,LRTSORU,LRTST,LRTSTS,LRUID,LRURG,LRVAL,LRWKCD
N LRWARD,LRWRDS,LRX,LRXX,LRYI,LRZX,M9,NODE,ODT,ORD
N PNM,RET,S,SN,SSN,TMPDIAL,VA,VADM,VAIN
N LREND,LRVAL,LRORPROV,LRSUBBY,X,X3,X4,Y
;
N COBR,COBX,IFN,IFN1,LRA,LRACD,LRANC0,LRAU,LRCS,LRD,LRFIRST
N LRO,LRP,LRSEL,LRSF,LRSOP,LRSTATI,LRSVC,LRTNAM
N LRU,LRWARDS,ORBMSG,ORCMSG,SRTN,X10,X5,X6,X7,X9,Z1
S LREND=0
D CK^LRAP I Y<0 Q
N X,Y
;;*
S LRLWC="WC"
;;;*
; Select peforming laboratory
I '$G(LRPL) S LRPL=DUZ(2) S LRVAL=$$SELPL^LRVERA(DUZ(2)) D END:LRVAL<1 Q:LRVAL<1 S LRPL=$S(LRVAL'=DUZ(2):LRVAL,1:DUZ(2))
L5 ;
Q:$G(LREND)
NEXT ;from LROE1
N LRVIDO,LRVIDOF D VIDEO^LRPARAM ; needed below - P509 PMK 5/22/17
K DIR,LRYI,LRAPTST,GOT,LRAPDIAL,LRNODE69,LRSUBMIT,LRPHY,LRAD,LRAA,LRLLOC,LROLLOC,LRSUBBY,LRORPROV D KVAR^LRX
I $D(LROESTAT) D:$P(LRPARAM,U,14) ^LRCAPV I $G(LREND) K LRLONG,LRPANEL Q
S (LRODT,X,DT)=$$DT^XLFDT(),LRODT0=$$FMTE^XLFDT(DT,5)
I '$D(^LRO(69,DT,1,0)) S ^LRO(69,DT,0)=DT,^LRO(69,DT,1,0)="^69.01PA^^",^LRO(69,"B",DT,DT)=""
I $D(^LAB(69.9,1,"RO")),+$H'=+$P(^("RO"),U) D
. W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$C(7),!
. S DIR("A")=" Are you sure you want to continue",DIR(0)="Y",DIR("B")="No"
I $T D ^DIR D END:$D(DIRUT) I Y'=1 W !,"OK, try later." D EN1
S X="T-7",%DT="" D ^%DT S LRTM7=+Y
K DIC,LRSND,LRSN,LRAPDIAL
W !!,"Select Order number: " R LRORD:DTIME I LRORD["."!($D(LRLONG)&(LRORD="")) W !,"Wrong format" G EN1
W @IOF S M9=0 G END:LRORD="^" I LRORD="" W !?5,"No Order Number entered use standard Specimen Log-in process",! Q
I $L(LRORD)>8 W !,"The order number entered is too long." H 1 G EN1
S:LRORD?.N LRORD=+LRORD IF LRORD'?.N D QMSG G EN1
I '$D(^LRO(69,"C",LRORD)) W !!?10,LRORD_" Does not exist, select another ",$C(7),! G EN1
L +^LRO(69,"C",LRORD):$G(DILOCKTM,3)
I '$T W !?5,"Someone else is editing this Order",!!,$C(7) G EN1
S (LRCHK,LRNONE)=1,(M9,LRODT)=0
F S LRODT=+$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 D
. S DA=0 F S DA=$O(^LRO(69,"C",LRORD,LRODT,DA)) Q:DA<1 S LRCHK=LRCHK-1 S:LRNONE'=2 LRNONE=0 D LROE2
I $G(LREND) D UNLOCK G EN1
I DOD'="" S Y=DOD D DD^LRX W !,!,?5,@LRVIDO,"Patient ",PNM," died on: ",Y,@LRVIDOF W !
D I Y=0!($D(DIRUT)) K DIRUT,DTOUT,DUOUT,Y D KVAR^LRX,UNLOCK G EN1
. K Y
. S DIR(0)="Y"
. S DIR("A")="Do you wish to continue with this accession [Yes/No]"
. S DIR("T")=120
. D ^DIR K DIR
I LRNONE=2,LRCHK<1 W !,"The order has already been partially accessioned." H 1
I LRNONE=2,LRCHK>0 W !,"The order has already been accessioned." H 1 D UNLOCK G NEXT
I LRNONE=1 W !,"No order exists with that number." H 1 D UNLOCK G NEXT
I '$$GOT(LRORD) W !!,"All tests for this order have been canceled.",! D UNLOCK G NEXT
S LRODT=$O(^LRO(69,"C",LRORD,0)),LRSN=$O(^LRO(69,"C",LRORD,LRODT,0))
I $P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)'="" W !?5,"Specimen already processed" D UNLOCK,END G EN1
; made PATHOLOGIST optional like legacy AP log-in - P509 PMK 5/25/17
K LRPHY D DOC(.LRPHY,"PATHOLOGIST") I $G(LREND) W !,"No Pathologist selected" D UNLOCK,END G EN1
S (LRPROVL,X)=+LRPHY D D^LRUA S LRPRAC(1)=X
D DATE(.LRCDT,"COLLECTION DATE/TIME") I $G(LRCDT)<1 D UNLOCK,END G EN1
S LRURG=9,LRAD=DT
S LRNODE69=^LRO(69,LRODT,1,LRSN,0)
S LRSUBBY="" I $D(^LRO(69,LRODT,1,LRSN,12))#2 S LRSUBBY=^(12) ;SUBMITTED BY
S LRORNUM=$G(^LRO(69,LRODT,1,LRSN,.1))
S LRSUBMIT=$P(LRNODE69,U,2),LRSUBMIT=$P(^VA(200,LRSUBMIT,0),U)_U_LRSUBMIT
S LRORIFN=$P(LRNODE69,U,11),LRORTYP=$P(LRNODE69,U,4)
S LRORPROV=+$P($G(^LRO(69,LRODT,1,LRSN,11)),U,3) ;Ordering Provider Optional
NEXT2 ;
S LRAPSPEC="",LRI=0
F S LRI=$O(^LRO(69,LRODT,1,LRSN,4,1,1,LRI)) Q:LRI<1 S LRAPSPEC(LRI)=^(LRI,0)
S LRLLOC=$P(LRNODE69,U,7),LROLLOC=$P(LRNODE69,U,9) S:LRLLOC="" LRLLOC="NO ABRV"
K LRCOM S LRCOM=""
N LRYI S LRYI=0 F S LRYI=$O(^LRO(69,LRODT,1,LRSN,2,1,1,LRYI)) Q:LRYI<1 D
. S LRCOM(LRYI)=(^(LRYI,0))
K LRYI K LRAPDIAL
F LRYI=13,14,15,16 M LRAPDIAL(".0"_LRYI)=^LRO(69,LRODT,1,LRSN,LRYI) K LRAPDIAL(".0"_LRYI,0)
K LRYI,LRAPTST,LRTST
S (LRAA,LRSS)=""
S LRYI=0 F S LRYI=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRYI)) Q:LRYI<1 S (LRTSORU,LRTST)=LRYI,LRAPTST(LRYI)="" D
. S LRWKCD=+$G(^LAB(60,+LRTST,64)),LRNLT=$P($G(^LAM(LRWKCD,0)),"^",2),II=1
. ;Get accession area for institution
. S LRAA=+$P($G(^LAB(60,LRTST,8,+$G(LRPL),0)),U,2)
. I 'LRAA D Q
. . S LRERR="[ "_$P($G(^LAB(60,LRTST,0)),U)_"] DOES NOT HAVE AN APPROPRIATE ACCESSION AREA DEFINED"
. . W !!,$$CJ^XLFSTR(LRERR,IOM)
. . W !,$$CJ^XLFSTR("Log-in Aborted",IOM),!
. . S LREND=1
. I LRAA S LRSS=$P(^LAB(60,LRTST,0),U,4)
. N LRI
. S LRI=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRYI,0))
. S LRAPTST(LRYI)=$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,7)
;;;*
I $G(LREND) K LRERR,LREND D UNLOCK,END G EN1
K LRDPF D PT^LRX
K LRYI D KVA^VADPT
S LRAPDIAL=1,LRAP690=$G(LROD0),LRSTATUS="C"
;;*
S LROUTINE=9
S X=$P(^LRO(68,LRAA,0),U) D ^LRUTL
S (Y,LRAD)=DT D LRAD^LRU
;;;*
D GETLOCK^LRWLST1(LRAA,LRAD)
D CHECK68^LRWLST1(LRAA,LRAD)
S:'$D(^LRO(68,LRAA,1,LRAD,1,0)) ^LRO(68,LRAA,1,LRAD,1,0)="^68.02PA^"
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
S LRAC=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN
D CRE863^LRAPLG1
K LRXX S LRXX(LRTST)="" D ORDTST
D MOVE(LRDFN,LRSS,LRIDT)
;
SET68 ;Setup ^LRO(68,LRAA,1,LRAD,1,LRAN
I LRSS'="AU" D
. K LRDIE D CRE868^LRAPLG1
. S X=^LR(LRDFN,LRSS,LRI,0),LRIDT=LRI,LRCAPLOC=""
. S LRSD=$P(X,U),LRRC=$P(X,U,10),LRACC=$P(X,U,6),LRMD(1)=$P(X,U,7),LRPRAC=$P(X,U,7),LRSIT=$P(X,U,5),LRCS=$P(X,U,11),LRLLOC=$P(X,U,8),LRC(5)=""
. K LRDIE D EN^LRUWLF
D UPD68
L -^LRO(68,LRAA,1,LRAD,1,0)
D UNLOCK
Q
;
MOVE(LRDFN,LRSS,LRI) ;Move CPRS AP Dialog to ^LR(LRDFN,LRSS,LRI)
;Check to see if Surgery Package Dialog is available
D ^LRAPKLG
;
N ANS,X,Y,ERR,IEN,FDA,FIL,LRX
S FIL=63.08,FLD=.013
S IEN=LRI_","_LRDFN_","
S:LRSS="SP" FIL=63.08
S:LRSS="CY" FIL=63.09
S:LRSS="EM" FIL=63.02
S LRX=0 F S LRX=$O(LRAPDIAL(LRX)) Q:LRX="" D
. K ERR D WP^DIE(FIL,IEN,LRX,"A","LRAPDIAL("_LRX_")","ERR")
Q
;
ORDTST ; Ordered test
N XX
S LRWKCD=+$G(^LAB(60,+$G(LRTST),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_"^"_+LRTST
Q
;
LROE2 ;
S LREND=0 I '$D(^LRO(69,LRODT,1,DA,0)) Q
N IEN,FLD,FIL,ANS
S FIL=69.01,FLD=13,IEN=DA_","_LRODT_","
S ANS=$$GET1^DIQ(FIL,IEN,13,,"ANS","ERR")
I $L(ANS) D Q
. W !,$$CJ^XLFSTR("The order# "_LRORD_" has been "_ANS,IOM),!
. W $$CJ^XLFSTR("Select another order",IOM),!
. S LREND=1
I $D(^LRO(69,LRODT,1,DA,1)) D
. I $P(^LRO(69,LRODT,1,DA,1),U,4)="C" S LRNONE=2,LRCHK=LRCHK+1 Q
. I $P(^LRO(69,LRODT,1,DA,0),U,4)="LC",$P(^LRO(69,LRODT,1,DA,1),U,4)="" S LRNONE=2,LRCHK=LRCHK+1
;
K LRSN
S (LRSN,LRSN(DA))=+DA,LREND=0
I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
I '$O(^LRO(69,LRODT,1,LRSN,13,0)) W !?5,"No AP Dialog for this order" S LREND=1 Q
S M9=$G(M9)+1,LRZX=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LRZX,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
I $G(VA("MRN"))]"" D
.W !,PNM,?30,$G(VA("MRN",0))_": "_SSN
.W !,?30,"DOB: "_$P($G(VADM(3)),U,2) S LRWRDS=LRWRD
E W !,PNM,?30,SSN S LRWRDS=LRWRD
W ?45,"Requesting location: ",$P(LRZX,U,7) S Y=$P(LRZX,U,5) D DD^LRX W !,"Date/Time Ordered: ",Y,?45,"By: ",$S($D(^VA(200,+$P(LRZX,U,2),0)):$P(^(0),U),1:"")
S LRSVSN=LRSN D ORDER^LROS S LRSN=LRSVSN
Q
;
;
QMSG W !,"Enter the order entry number assigned when the test was ordered."
W:'$D(LRLONG) !,"If the test has not been ordered, type the RETURN key to exit."
W !,"To exit, type the ""^"" key and RETURN key."
Q
;
;
END K DIR,DIRUT,GOT
D ^LRORDK,LROEND^LRORDK,STOP^LRCAPV,CLEAN D KVAR^LRX
S LREND=1
Q
;
;
GOT(ORD) ;See if all tests have been canceled
N I,SN,ODT
S (GOT,ODT,SN)=0
F S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1 D
. S SN=0 F S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1!(GOT) D
. . Q:'$D(^LRO(69,ODT,1,SN,0))
. . S I=0 F S I=$O(^LRO(69,ODT,1,SN,2,I)) Q:I<1 I $D(^(I,0)),'$P(^(0),"^",11) S GOT=1 Q
Q GOT
;
UPD68 ; Update #68 with required test data
N LRFILE,ERR,IEN,LRI,LRIEN,LRCNT
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","ERR(3)")
;
;
SPEC68 ; Update #68 with specimen data
S (LRI,LRCNT)=0 F S LRI=$O(LRAPSPEC(LRI)) Q:LRI<1 D
. K LRFILE,FDAIEN,IEN
. S LRFILE=68.05,LRCNT=LRCNT+1
. S LRSPEC=$P(LRAPSPEC(LRI),U,6)
. S LRSAMP=$P(LRAPSPEC(LRI),U,7)
. 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)")
;
S LRCAPA=$P(^LAB(69.9,1,0),"^",14)&($P(^LRO(68,LRAA,0),"^",16))
I $G(LRCAPA) D WKLD ; Stuff workload data into accession.
;
D LR7OB1 ;;Update CPRS to active status
;
D LR7OFAO ;Update ^LRO(69 with accession data.
;
D SPEC63(LRDFN,LRSS,LRIDT,.LRAPSPEC) ;Load AP Specimens into ^LR(
;
D LRCOM(LRDFN,LRSS,LRIDT,.LRCOM) ; Store comments into ^LR(
;
D SLRSS^LRWLST11 ;Populate the ^LR(LRDFN,LRSS,LRIDT,"ORU" with UID
;
D ORUT^LRWLST11 ;Populate the ^LR(LRDFN,LRSS,LRIDT,"ORUT" with test data
;
D DIS63(LRDFN,LRSS,LRIDT) ; Display ^LR(LRDFN,LRSS,LRIDT) data.
;
W !,$$CJ^XLFSTR("**** Enter Next Order ****",IOM),!
Q
DOC(RET,LABEL) ; Return provider
;IN = RET by reference
; Label is the prompt the user will see
;OUT = LREND=1 if user fails to answer the prompt correctly
; RET = +y
; RET(0) = IEN^.01 FIELD
N DIR,X,Y,DIRUT,DTOUT,DUOUT
; made PATHOLOGIST optional like legacy AP log-in - P509 PMK 5/25/17
S DIR(0)="PO^200:EQMF",LREND=0 ; PATHOLOGIST is optional
S DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))"
S DIR("A")=LABEL
D ^DIR
I $G(DIRUT),((Y["^")!(Y="")) S LREND=1 Q
I Y=-1 S Y=""
S RET=+Y,RET(0)=Y
Q
DATE(RET,LABEL) ;
;
;IN = RET by reference
; Label is the prompt the user will see
;OUT = LREND=1 if user fails to answer the prompt correctly
; RET = Y
N DIR,X,Y,DIRUT,DTOUT,DUOUT
S LREND=0,DIR("A")=LABEL,DIR("?")="Date can not be in the future"
S DIR(0)="D^:-NOW:EXT"
D ^DIR
I Y<1 S LREND=1
S RET=Y
Q
DA(Y) ; Returns date in eye-readable month format
Q $$FMTE^XLFDT(Y,"M")
Q
LR7OB1 ;Update CPRS to active status
K DIERR,IEN,LRFDA,ERR
K ERR
S LRORD=+$G(^LRO(69,LRODT,1,LRSN,.1))
S IEN=LRSN_","_LRODT_","
I '$G(^LRO(69,LRODT,1,LRSN,1)) D
. S LRFDA(1,69.01,IEN,10)=+$G(LRCDT,$$NOW^XLFDT)
. S LRFDA(1,69.01,IEN,12)=DUZ
. S LRFDA(1,69.01,IEN,13)="C"
. I $G(LRPL) S LRFDA(1,69.01,IEN,25)=+$G(LRPL)
. S LRFDA(1,69.01,IEN,20)=LRNT
. D UPDATE^DIE("KS","LRFDA(1)","IEN","ERR")
K ^LRO(69,"AA",LRODT_"|"_LRSN) ;DD 69.01,13 is incorrect
S ^LRO(69,"AA",LRORD,LRODT_"|"_LRSN)=""
;Update status in OR(100,
S LRORIFN=+$P($G(^LRO(69,LRODT,1,LRSN,2,1,0)),"^",7) D
. S CONTROL=$S($G(LRORIFN):"SC",1:"SN")
. D NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
Q
LR7OFAO ;Update ^LRO(69 with accession data.
;
K IEN,LRFDA,LRFDAIEN,LRMSG,DIERR
S IEN="?+1,"_LRSN_","_LRODT_","
S LRFDA(6,69.03,IEN,.01)=LRTST
I $G(LROUTINE) S LRFDA(6,69.03,IEN,1)=LROUTINE
S LRFDA(6,69.03,IEN,2)=LRAD
S LRFDA(6,69.03,IEN,3)=LRAA
S LRFDA(6,69.03,IEN,4)=LRAN
S LRFDA(6,69.03,IEN,13)=LRUID
S LRFDA(6,69.03,IEN,8)="IP"
S LRFDA(6,69.03,IEN,9)="L"
D UPDATE^DIE("","LRFDA(6)","LRFDAIEN","LRMSG")
Q
DIS63(LRDFN,LRSS,LRIDT) ;Display ^LR(LRDFN,LRSS,LRIDT data
Q:'$G(^LR(LRDFN,LRSS,LRIDT,0))
W @IOF,!!,$$CJ^XLFSTR("-------------------------------------",IOM),!
W $$CJ^XLFSTR("Display of CPRS data in LAB DATA file",IOM),!
N ANS,DIC,DA,DR,ERR,CNT,ID,IEN,LREND,LRFILE,LRPAGE,S
S DA=LRIDT,DA(1)=LRDFN,LREND=0
S DIC="^LR("_LRDFN_","_""""_LRSS_""""_",",DR=0,S=1
D EN^DIQ S LRPAGE=S
S LRFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0)
S IEN=DA_","_DA(1)_","
D GETS^DIQ(LRFILE,IEN,".01:16","ERRZ","ANS","ERR")
F ID="BRIEF CLINICAL HISTORY","PREOPERATIVE DIAGNOSIS","OPERATIVE FINDINGS","POSTOPERATIVE DIAGNOSIS" Q:$G(LREND) D
. I $O(ANS(LRFILE,IEN,ID,0)) W !?5,ID_":" D PAGE Q:$G(LREND) D
. . S CNT=0 F S CNT=$O(ANS(LRFILE,IEN,ID,CNT)) Q:CNT<1!($G(LREND)) D
. . . W !,ANS(LRFILE,IEN,ID,CNT,0) D PAGE
W:'$G(LREND) !!,$$CJ^XLFSTR("--- End of CPRS data in LAB DATA file ---",IOM),!
;
; VistA Imaging changes - P509 PMK 5/10/17
I $T(ADD^MAGTP005)'="" D ADD^MAGTP005(LRAC) ; add case to file #2005.42
N LRI S LRI=LRIDT ; LRI is used in MAGT7MA instead of LRIDT
I $T(NEW^MAGT7MA)'="" D NEW^MAGT7MA ; invoke Imaging HL7 routine
Q
;
SPEC63(LRDFN,LRSS,LRIDT,LRAPSPEC) ;Load AP Specimens into ^LR(
; INPUT LRAPSPEC(1)="CERVICAL CYTOLOGIC MATERIAL,Thin Prep^^^^^6242^55"
;
K LRFDA,IEN,IENX,ERR,ERR2,WPIEN68,NODE,ANS,ANSY,LRSP,LRCOL
K LRJ,NODE,LRFILE,LRSPCOM,LRSPEC,LRSAMP
;
Q:LRSS="AU"!(LRSS="BB")
S LRFILE=$S(LRSS="SP":63.812,LRSS="CY":63.902,LRSS="EM":63.202,1:0)
S IEN="+1,"_LRIDT_","_LRDFN_","
S:'$G(IENX) IENX=0 F S IENX=$O(LRAPSPEC(IENX)) Q:IENX<1 D
. S NODE=LRAPSPEC(IENX),LRSPCOM=$P(NODE,U),LRSPEC=+$P(NODE,U,6),LRSAMP=$P(NODE,U,7)
. Q:$S('LRSPEC:1,'LRSAMP:1,1:0)
. K LRFDA,ERR,ANSY
. S LRFDA(2,LRFILE,IEN,.01)=LRSPCOM ;Specimen Description
. S LRFDA(2,LRFILE,IEN,.06)=LRSPEC ;Specimen ^LAB(61,LRSP
. S LRFDA(2,LRFILE,IEN,.07)=LRSAMP ; Collection Sample ^LAB(62,LRCOL
. D UPDATE^DIE("KS","LRFDA(2)","ANSY(1)","ERR")
Q
LRCOM(LRDFN,LRSS,LRIDT,LRCOM) ;Store Comments into ^LR(
;IN LRCOM(1)="~For Test: GYNECOLOGY"
K LRFILE,LRFDA,IEN,CNT
S LRFILE=$S(LRSS="CH":63.041,LRSS="MI":63.05,LRSS="SP":63.98,LRSS="CY":63.908,LRSS="EM":63.208,1:"")
Q:'LRFILE
S IEN="+1,"_LRIDT_","_LRDFN_",",CNT=0
F S CNT=$O(LRCOM(CNT)) Q:CNT<1 D
. K LRFDA,ERR
. S LRFDA(9,LRFILE,IEN,.01)=LRCOM(CNT)
. D UPDATE^DIE("KS","LRFDA(9)","","ERR")
Q
CLEAN ;Kill variable
Q
WKLD ;Setup workload info
;
N LR,LRI,LRK,LRRC,LRT,LRW
S LRI=LRIDT
S LRRC=$S($G(LRCDT):LRCDT,1:$$NOW^XLFDT)
S LRCAPA=$P(^LAB(69.9,1,0),"^",14)&($P(^LRO(68,LRAA,0),"^",16))
;
S LR("L")=LRSS_"^LRAP" I LRCAPA,"AUSP"[LRSS S X=$S(LRSS="SP":"H & E STAIN",1:"AUTOPSY H & E") D X^LRUWK I $D(X) S LRW("H&E")=LRT D ^LRAPSWK
;
I LRCAPA,LRSS="EM" S X="THICK SECTION EM" D X^LRUWK I $D(X) S X=11 D SET1 S LRW("SS")=LRT_U_X S X="GRID EM" D X^LRUWK I $D(X) S X=12 D SET1 S LRW("G")=LRT_U_X D ^LRAPSWK
;
I LRCAPA D
. K LRT S LRT=0 F S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<1 D
. . Q:$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,2)>49
. . I LRSS="CY" D ^LRAPCWK
. . I LRSS?1(1"SP",1"EM") D ^LRAPSWK,^LRSPGD
;
Q
SET1 S X=$P($G(^LRO(69.2,LRAA,0)),"^",X) S:'X X=1
Q
PAGE ;Page Prompt
Q:$E(IOST,1)'="C"
S LRPAGE=$G(LRPAGE)+1,LREND=0 Q:LRPAGE<(IOSL-2)
S DIR(0)="E" D ^DIR K DIR I $G(Y)=0 S LREND=1 Q
S LRPAGE=2 W @IOF
Q
;
UNLOCK ;
I $G(LRORD)'="" L -^LRO(69,"C",LRORD)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPKOE 15978 printed Sep 23, 2025@19:43:13 Page 2
LRAPKOE ;DSS/FHS - CRPS AP LAB ORDER ENTRY AND ACCESSION ;Jun 21, 2022@15:03:04
+1 ;;5.2;LAB SERVICE;**462,479,483,509,553**;Sep 27, 1994;Build 21
+2 ; Supported calls AI #, 5286,103,3615
EN1 ;
+1 ; Called from EN^LRAPLG
+2 ; Process CPRS AP Orders
+3 NEW ANS,ANSY,CNT,CONTROL,DA,DIC,DIERR,DIR,DIRUT,DOD,DR
+4 NEW DTOUT,DUOUT,ERR,FDA,FDAIEN,FIL,FLD,GOT,IEN,IENX,II
+5 NEW LR,LRAA,LRACN,LRACN0,LRAP690,LRAPNT,LRAPSPEC
+6 NEW LRAPTST,LRC,LRCAPA,LRCAPLOC,LRCHK
+7 NEW LRCOL,LRCOM,LRC5,LRDFN,LRDISC,LRDIE,LRDOC,LRDPF,LREND,LRFDA
+8 NEW LRFDAIEN,LRI,LRIDT,LRIEN,LRJ,LRLL,LRLLOC,LRLWC,LRMD,LRMSG
+9 NEW LRNATURE,LRNLT,LRNODE69,LRNONE,LROD0,LROD1,LROD3,LRODT,LRODT0
+10 NEW LROESTAT,LROLLOC,LRORD,LRORDRR,LROOS,LRORD,LRORDRR
+11 NEW LRORIFN,LRORNUM,LRORPOV,LRORTYP,LRORU3,LROS,LROSD,LRPRAC,LRPANEL,LRPHY,LRPL
+12 NEW LRPROVL,LRRC,LRROD,LRSAMP,LRSD,LRSIT,LRSN,LRSND
+13 NEW LRSP,LRSPCOM,LRSPEC,LRSS,LRSTATUS,LRSUBBY,LRSUBMIT
+14 NEW LRSVSN,LRT,LRTM7,LRTSORU,LRTST,LRTSTS,LRUID,LRURG,LRVAL,LRWKCD
+15 NEW LRWARD,LRWRDS,LRX,LRXX,LRYI,LRZX,M9,NODE,ODT,ORD
+16 NEW PNM,RET,S,SN,SSN,TMPDIAL,VA,VADM,VAIN
+17 NEW LREND,LRVAL,LRORPROV,LRSUBBY,X,X3,X4,Y
+18 ;
+19 NEW COBR,COBX,IFN,IFN1,LRA,LRACD,LRANC0,LRAU,LRCS,LRD,LRFIRST
+20 NEW LRO,LRP,LRSEL,LRSF,LRSOP,LRSTATI,LRSVC,LRTNAM
+21 NEW LRU,LRWARDS,ORBMSG,ORCMSG,SRTN,X10,X5,X6,X7,X9,Z1
+22 SET LREND=0
+23 DO CK^LRAP
IF Y<0
QUIT
+24 NEW X,Y
+25 ;;*
+26 SET LRLWC="WC"
+27 ;;;*
+28 ; Select peforming laboratory
+29 IF '$GET(LRPL)
SET LRPL=DUZ(2)
SET LRVAL=$$SELPL^LRVERA(DUZ(2))
if LRVAL<1
DO END
if LRVAL<1
QUIT
SET LRPL=$SELECT(LRVAL'=DUZ(2):LRVAL,1:DUZ(2))
L5 ;
+1 if $GET(LREND)
QUIT
NEXT ;from LROE1
+1 ; needed below - P509 PMK 5/22/17
NEW LRVIDO,LRVIDOF
DO VIDEO^LRPARAM
+2 KILL DIR,LRYI,LRAPTST,GOT,LRAPDIAL,LRNODE69,LRSUBMIT,LRPHY,LRAD,LRAA,LRLLOC,LROLLOC,LRSUBBY,LRORPROV
DO KVAR^LRX
+3 IF $DATA(LROESTAT)
if $PIECE(LRPARAM,U,14)
DO ^LRCAPV
IF $GET(LREND)
KILL LRLONG,LRPANEL
QUIT
+4 SET (LRODT,X,DT)=$$DT^XLFDT()
SET LRODT0=$$FMTE^XLFDT(DT,5)
+5 IF '$DATA(^LRO(69,DT,1,0))
SET ^LRO(69,DT,0)=DT
SET ^LRO(69,DT,1,0)="^69.01PA^^"
SET ^LRO(69,"B",DT,DT)=""
+6 IF $DATA(^LAB(69.9,1,"RO"))
IF +$HOROLOG'=+$PIECE(^("RO"),U)
Begin DoDot:1
+7 WRITE $CHAR(7),!,"ROLLOVER ",$SELECT($PIECE(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$CHAR(7),!
+8 SET DIR("A")=" Are you sure you want to continue"
SET DIR(0)="Y"
SET DIR("B")="No"
End DoDot:1
+9 IF $TEST
DO ^DIR
if $DATA(DIRUT)
DO END
IF Y'=1
WRITE !,"OK, try later."
DO EN1
+10 SET X="T-7"
SET %DT=""
DO ^%DT
SET LRTM7=+Y
+11 KILL DIC,LRSND,LRSN,LRAPDIAL
+12 WRITE !!,"Select Order number: "
READ LRORD:DTIME
IF LRORD["."!($DATA(LRLONG)&(LRORD=""))
WRITE !,"Wrong format"
GOTO EN1
+13 WRITE @IOF
SET M9=0
if LRORD="^"
GOTO END
IF LRORD=""
WRITE !?5,"No Order Number entered use standard Specimen Log-in process",!
QUIT
+14 IF $LENGTH(LRORD)>8
WRITE !,"The order number entered is too long."
HANG 1
GOTO EN1
+15 if LRORD?.N
SET LRORD=+LRORD
IF LRORD'?.N
DO QMSG
GOTO EN1
+16 IF '$DATA(^LRO(69,"C",LRORD))
WRITE !!?10,LRORD_" Does not exist, select another ",$CHAR(7),!
GOTO EN1
+17 LOCK +^LRO(69,"C",LRORD):$GET(DILOCKTM,3)
+18 IF '$TEST
WRITE !?5,"Someone else is editing this Order",!!,$CHAR(7)
GOTO EN1
+19 SET (LRCHK,LRNONE)=1
SET (M9,LRODT)=0
+20 FOR
SET LRODT=+$ORDER(^LRO(69,"C",LRORD,LRODT))
if LRODT<1
QUIT
Begin DoDot:1
+21 SET DA=0
FOR
SET DA=$ORDER(^LRO(69,"C",LRORD,LRODT,DA))
if DA<1
QUIT
SET LRCHK=LRCHK-1
if LRNONE'=2
SET LRNONE=0
DO LROE2
End DoDot:1
+22 IF $GET(LREND)
DO UNLOCK
GOTO EN1
+23 IF DOD'=""
SET Y=DOD
DO DD^LRX
WRITE !,!,?5,@LRVIDO,"Patient ",PNM," died on: ",Y,@LRVIDOF
WRITE !
+24 Begin DoDot:1
+25 KILL Y
+26 SET DIR(0)="Y"
+27 SET DIR("A")="Do you wish to continue with this accession [Yes/No]"
+28 SET DIR("T")=120
+29 DO ^DIR
KILL DIR
End DoDot:1
IF Y=0!($DATA(DIRUT))
KILL DIRUT,DTOUT,DUOUT,Y
DO KVAR^LRX
DO UNLOCK
GOTO EN1
+30 IF LRNONE=2
IF LRCHK<1
WRITE !,"The order has already been partially accessioned."
HANG 1
+31 IF LRNONE=2
IF LRCHK>0
WRITE !,"The order has already been accessioned."
HANG 1
DO UNLOCK
GOTO NEXT
+32 IF LRNONE=1
WRITE !,"No order exists with that number."
HANG 1
DO UNLOCK
GOTO NEXT
+33 IF '$$GOT(LRORD)
WRITE !!,"All tests for this order have been canceled.",!
DO UNLOCK
GOTO NEXT
+34 SET LRODT=$ORDER(^LRO(69,"C",LRORD,0))
SET LRSN=$ORDER(^LRO(69,"C",LRORD,LRODT,0))
+35 IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,4)'=""
WRITE !?5,"Specimen already processed"
DO UNLOCK
DO END
GOTO EN1
+36 ; made PATHOLOGIST optional like legacy AP log-in - P509 PMK 5/25/17
+37 KILL LRPHY
DO DOC(.LRPHY,"PATHOLOGIST")
IF $GET(LREND)
WRITE !,"No Pathologist selected"
DO UNLOCK
DO END
GOTO EN1
+38 SET (LRPROVL,X)=+LRPHY
DO D^LRUA
SET LRPRAC(1)=X
+39 DO DATE(.LRCDT,"COLLECTION DATE/TIME")
IF $GET(LRCDT)<1
DO UNLOCK
DO END
GOTO EN1
+40 SET LRURG=9
SET LRAD=DT
+41 SET LRNODE69=^LRO(69,LRODT,1,LRSN,0)
+42 ;SUBMITTED BY
SET LRSUBBY=""
IF $DATA(^LRO(69,LRODT,1,LRSN,12))#2
SET LRSUBBY=^(12)
+43 SET LRORNUM=$GET(^LRO(69,LRODT,1,LRSN,.1))
+44 SET LRSUBMIT=$PIECE(LRNODE69,U,2)
SET LRSUBMIT=$PIECE(^VA(200,LRSUBMIT,0),U)_U_LRSUBMIT
+45 SET LRORIFN=$PIECE(LRNODE69,U,11)
SET LRORTYP=$PIECE(LRNODE69,U,4)
+46 ;Ordering Provider Optional
SET LRORPROV=+$PIECE($GET(^LRO(69,LRODT,1,LRSN,11)),U,3)
NEXT2 ;
+1 SET LRAPSPEC=""
SET LRI=0
+2 FOR
SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,4,1,1,LRI))
if LRI<1
QUIT
SET LRAPSPEC(LRI)=^(LRI,0)
+3 SET LRLLOC=$PIECE(LRNODE69,U,7)
SET LROLLOC=$PIECE(LRNODE69,U,9)
if LRLLOC=""
SET LRLLOC="NO ABRV"
+4 KILL LRCOM
SET LRCOM=""
+5 NEW LRYI
SET LRYI=0
FOR
SET LRYI=$ORDER(^LRO(69,LRODT,1,LRSN,2,1,1,LRYI))
if LRYI<1
QUIT
Begin DoDot:1
+6 SET LRCOM(LRYI)=(^(LRYI,0))
End DoDot:1
+7 KILL LRYI
KILL LRAPDIAL
+8 FOR LRYI=13,14,15,16
MERGE LRAPDIAL(".0"_LRYI)=^LRO(69,LRODT,1,LRSN,LRYI)
KILL LRAPDIAL(".0"_LRYI,0)
+9 KILL LRYI,LRAPTST,LRTST
+10 SET (LRAA,LRSS)=""
+11 SET LRYI=0
FOR
SET LRYI=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRYI))
if LRYI<1
QUIT
SET (LRTSORU,LRTST)=LRYI
SET LRAPTST(LRYI)=""
Begin DoDot:1
+12 SET LRWKCD=+$GET(^LAB(60,+LRTST,64))
SET LRNLT=$PIECE($GET(^LAM(LRWKCD,0)),"^",2)
SET II=1
+13 ;Get accession area for institution
+14 SET LRAA=+$PIECE($GET(^LAB(60,LRTST,8,+$GET(LRPL),0)),U,2)
+15 IF 'LRAA
Begin DoDot:2
+16 SET LRERR="[ "_$PIECE($GET(^LAB(60,LRTST,0)),U)_"] DOES NOT HAVE AN APPROPRIATE ACCESSION AREA DEFINED"
+17 WRITE !!,$$CJ^XLFSTR(LRERR,IOM)
+18 WRITE !,$$CJ^XLFSTR("Log-in Aborted",IOM),!
+19 SET LREND=1
End DoDot:2
QUIT
+20 IF LRAA
SET LRSS=$PIECE(^LAB(60,LRTST,0),U,4)
+21 NEW LRI
+22 SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRYI,0))
+23 SET LRAPTST(LRYI)=$PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,7)
End DoDot:1
+24 ;;;*
+25 IF $GET(LREND)
KILL LRERR,LREND
DO UNLOCK
DO END
GOTO EN1
+26 KILL LRDPF
DO PT^LRX
+27 KILL LRYI
DO KVA^VADPT
+28 SET LRAPDIAL=1
SET LRAP690=$GET(LROD0)
SET LRSTATUS="C"
+29 ;;*
+30 SET LROUTINE=9
+31 SET X=$PIECE(^LRO(68,LRAA,0),U)
DO ^LRUTL
+32 SET (Y,LRAD)=DT
DO LRAD^LRU
+33 ;;;*
+34 DO GETLOCK^LRWLST1(LRAA,LRAD)
+35 DO CHECK68^LRWLST1(LRAA,LRAD)
+36 if '$DATA(^LRO(68,LRAA,1,LRAD,1,0))
SET ^LRO(68,LRAA,1,LRAD,1,0)="^68.02PA^"
+37 SET LRAN=+$PIECE(^LRO(68,LRAA,1,LRAD,1,0),U,3)
+38 FOR
if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))
QUIT
SET LRAN=LRAN+1
+39 SET LRAC=$PIECE(^LRO(68,LRAA,0),U,11)_" "_$SELECT(LRAD["0000":$EXTRACT(LRAD,2,3),1:$EXTRACT(LRAD,4,7))_" "_LRAN
+40 DO CRE863^LRAPLG1
+41 KILL LRXX
SET LRXX(LRTST)=""
DO ORDTST
+42 DO MOVE(LRDFN,LRSS,LRIDT)
+43 ;
SET68 ;Setup ^LRO(68,LRAA,1,LRAD,1,LRAN
+1 IF LRSS'="AU"
Begin DoDot:1
+2 KILL LRDIE
DO CRE868^LRAPLG1
+3 SET X=^LR(LRDFN,LRSS,LRI,0)
SET LRIDT=LRI
SET LRCAPLOC=""
+4 SET LRSD=$PIECE(X,U)
SET LRRC=$PIECE(X,U,10)
SET LRACC=$PIECE(X,U,6)
SET LRMD(1)=$PIECE(X,U,7)
SET LRPRAC=$PIECE(X,U,7)
SET LRSIT=$PIECE(X,U,5)
SET LRCS=$PIECE(X,U,11)
SET LRLLOC=$PIECE(X,U,8)
SET LRC(5)=""
+5 KILL LRDIE
DO EN^LRUWLF
End DoDot:1
+6 DO UPD68
+7 LOCK -^LRO(68,LRAA,1,LRAD,1,0)
+8 DO UNLOCK
+9 QUIT
+10 ;
MOVE(LRDFN,LRSS,LRI) ;Move CPRS AP Dialog to ^LR(LRDFN,LRSS,LRI)
+1 ;Check to see if Surgery Package Dialog is available
+2 DO ^LRAPKLG
+3 ;
+4 NEW ANS,X,Y,ERR,IEN,FDA,FIL,LRX
+5 SET FIL=63.08
SET FLD=.013
+6 SET IEN=LRI_","_LRDFN_","
+7 if LRSS="SP"
SET FIL=63.08
+8 if LRSS="CY"
SET FIL=63.09
+9 if LRSS="EM"
SET FIL=63.02
+10 SET LRX=0
FOR
SET LRX=$ORDER(LRAPDIAL(LRX))
if LRX=""
QUIT
Begin DoDot:1
+11 KILL ERR
DO WP^DIE(FIL,IEN,LRX,"A","LRAPDIAL("_LRX_")","ERR")
End DoDot:1
+12 QUIT
+13 ;
ORDTST ; Ordered test
+1 NEW XX
+2 SET LRWKCD=+$GET(^LAB(60,+$GET(LRTST),64))
SET LRNLT=$PIECE($GET(^LAM(LRWKCD,0)),"^",2)
SET II=1
+3 SET XX=0
+4 FOR
SET XX=$ORDER(LRXX(XX))
if 'XX
QUIT
SET $PIECE(LRXX(XX),"^",2)=LRNLT_"^"_+LRTST
+5 QUIT
+6 ;
LROE2 ;
+1 SET LREND=0
IF '$DATA(^LRO(69,LRODT,1,DA,0))
QUIT
+2 NEW IEN,FLD,FIL,ANS
+3 SET FIL=69.01
SET FLD=13
SET IEN=DA_","_LRODT_","
+4 SET ANS=$$GET1^DIQ(FIL,IEN,13,,"ANS","ERR")
+5 IF $LENGTH(ANS)
Begin DoDot:1
+6 WRITE !,$$CJ^XLFSTR("The order# "_LRORD_" has been "_ANS,IOM),!
+7 WRITE $$CJ^XLFSTR("Select another order",IOM),!
+8 SET LREND=1
End DoDot:1
QUIT
+9 IF $DATA(^LRO(69,LRODT,1,DA,1))
Begin DoDot:1
+10 IF $PIECE(^LRO(69,LRODT,1,DA,1),U,4)="C"
SET LRNONE=2
SET LRCHK=LRCHK+1
QUIT
+11 IF $PIECE(^LRO(69,LRODT,1,DA,0),U,4)="LC"
IF $PIECE(^LRO(69,LRODT,1,DA,1),U,4)=""
SET LRNONE=2
SET LRCHK=LRCHK+1
End DoDot:1
+12 ;
+13 KILL LRSN
+14 SET (LRSN,LRSN(DA))=+DA
SET LREND=0
+15 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
QUIT
+16 IF '$ORDER(^LRO(69,LRODT,1,LRSN,13,0))
WRITE !?5,"No AP Dialog for this order"
SET LREND=1
QUIT
+17 SET M9=$GET(M9)+1
SET LRZX=^LRO(69,LRODT,1,LRSN,0)
SET LRDFN=+LRZX
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+18 DO PT^LRX
+19 IF $GET(VA("MRN"))]""
Begin DoDot:1
+20 WRITE !,PNM,?30,$GET(VA("MRN",0))_": "_SSN
+21 WRITE !,?30,"DOB: "_$PIECE($GET(VADM(3)),U,2)
SET LRWRDS=LRWRD
End DoDot:1
+22 IF '$TEST
WRITE !,PNM,?30,SSN
SET LRWRDS=LRWRD
+23 WRITE ?45,"Requesting location: ",$PIECE(LRZX,U,7)
SET Y=$PIECE(LRZX,U,5)
DO DD^LRX
WRITE !,"Date/Time Ordered: ",Y,?45,"By: ",$SELECT($DATA(^VA(200,+$PIECE(LRZX,U,2),0)):$PIECE(^(0),U),1:"")
+24 SET LRSVSN=LRSN
DO ORDER^LROS
SET LRSN=LRSVSN
+25 QUIT
+26 ;
+27 ;
QMSG WRITE !,"Enter the order entry number assigned when the test was ordered."
+1 if '$DATA(LRLONG)
WRITE !,"If the test has not been ordered, type the RETURN key to exit."
+2 WRITE !,"To exit, type the ""^"" key and RETURN key."
+3 QUIT
+4 ;
+5 ;
END KILL DIR,DIRUT,GOT
+1 DO ^LRORDK
DO LROEND^LRORDK
DO STOP^LRCAPV
DO CLEAN
DO KVAR^LRX
+2 SET LREND=1
+3 QUIT
+4 ;
+5 ;
GOT(ORD) ;See if all tests have been canceled
+1 NEW I,SN,ODT
+2 SET (GOT,ODT,SN)=0
+3 FOR
SET ODT=$ORDER(^LRO(69,"C",ORD,ODT))
if ODT<1
QUIT
Begin DoDot:1
+4 SET SN=0
FOR
SET SN=$ORDER(^LRO(69,"C",ORD,ODT,SN))
if SN<1!(GOT)
QUIT
Begin DoDot:2
+5 if '$DATA(^LRO(69,ODT,1,SN,0))
QUIT
+6 SET I=0
FOR
SET I=$ORDER(^LRO(69,ODT,1,SN,2,I))
if I<1
QUIT
IF $DATA(^(I,0))
IF '$PIECE(^(0),"^",11)
SET GOT=1
QUIT
End DoDot:2
End DoDot:1
+7 QUIT GOT
+8 ;
UPD68 ; Update #68 with required test data
+1 NEW LRFILE,ERR,IEN,LRI,LRIEN,LRCNT
+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 SET FDA(3,LRFILE,LRIEN,8.1)=LRTST
+7 DO UPDATE^DIE("","FDA(3)","IEN","ERR(3)")
+8 ;
+9 ;
SPEC68 ; Update #68 with specimen data
+1 SET (LRI,LRCNT)=0
FOR
SET LRI=$ORDER(LRAPSPEC(LRI))
if LRI<1
QUIT
Begin DoDot:1
+2 KILL LRFILE,FDAIEN,IEN
+3 SET LRFILE=68.05
SET LRCNT=LRCNT+1
+4 SET LRSPEC=$PIECE(LRAPSPEC(LRI),U,6)
+5 SET LRSAMP=$PIECE(LRAPSPEC(LRI),U,7)
+6 SET FDAIEN="?+"_LRCNT_","_LRAN_","_LRAD_","_LRAA_","
+7 SET FDA(31,LRFILE,FDAIEN,.01)=LRSPEC
+8 SET FDA(31,LRFILE,FDAIEN,1)=LRSAMP
+9 DO UPDATE^DIE("","FDA(31)","IEN","LRERR(31)")
End DoDot:1
+10 ;
+11 SET LRCAPA=$PIECE(^LAB(69.9,1,0),"^",14)&($PIECE(^LRO(68,LRAA,0),"^",16))
+12 ; Stuff workload data into accession.
IF $GET(LRCAPA)
DO WKLD
+13 ;
+14 ;;Update CPRS to active status
DO LR7OB1
+15 ;
+16 ;Update ^LRO(69 with accession data.
DO LR7OFAO
+17 ;
+18 ;Load AP Specimens into ^LR(
DO SPEC63(LRDFN,LRSS,LRIDT,.LRAPSPEC)
+19 ;
+20 ; Store comments into ^LR(
DO LRCOM(LRDFN,LRSS,LRIDT,.LRCOM)
+21 ;
+22 ;Populate the ^LR(LRDFN,LRSS,LRIDT,"ORU" with UID
DO SLRSS^LRWLST11
+23 ;
+24 ;Populate the ^LR(LRDFN,LRSS,LRIDT,"ORUT" with test data
DO ORUT^LRWLST11
+25 ;
+26 ; Display ^LR(LRDFN,LRSS,LRIDT) data.
DO DIS63(LRDFN,LRSS,LRIDT)
+27 ;
+28 WRITE !,$$CJ^XLFSTR("**** Enter Next Order ****",IOM),!
+29 QUIT
DOC(RET,LABEL) ; Return provider
+1 ;IN = RET by reference
+2 ; Label is the prompt the user will see
+3 ;OUT = LREND=1 if user fails to answer the prompt correctly
+4 ; RET = +y
+5 ; RET(0) = IEN^.01 FIELD
+6 NEW DIR,X,Y,DIRUT,DTOUT,DUOUT
+7 ; made PATHOLOGIST optional like legacy AP log-in - P509 PMK 5/25/17
+8 ; PATHOLOGIST is optional
SET DIR(0)="PO^200:EQMF"
SET LREND=0
+9 SET DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))"
+10 SET DIR("A")=LABEL
+11 DO ^DIR
+12 IF $GET(DIRUT)
IF ((Y["^")!(Y=""))
SET LREND=1
QUIT
+13 IF Y=-1
SET Y=""
+14 SET RET=+Y
SET RET(0)=Y
+15 QUIT
DATE(RET,LABEL) ;
+1 ;
+2 ;IN = RET by reference
+3 ; Label is the prompt the user will see
+4 ;OUT = LREND=1 if user fails to answer the prompt correctly
+5 ; RET = Y
+6 NEW DIR,X,Y,DIRUT,DTOUT,DUOUT
+7 SET LREND=0
SET DIR("A")=LABEL
SET DIR("?")="Date can not be in the future"
+8 SET DIR(0)="D^:-NOW:EXT"
+9 DO ^DIR
+10 IF Y<1
SET LREND=1
+11 SET RET=Y
+12 QUIT
DA(Y) ; Returns date in eye-readable month format
+1 QUIT $$FMTE^XLFDT(Y,"M")
+2 QUIT
LR7OB1 ;Update CPRS to active status
+1 KILL DIERR,IEN,LRFDA,ERR
+2 KILL ERR
+3 SET LRORD=+$GET(^LRO(69,LRODT,1,LRSN,.1))
+4 SET IEN=LRSN_","_LRODT_","
+5 IF '$GET(^LRO(69,LRODT,1,LRSN,1))
Begin DoDot:1
+6 SET LRFDA(1,69.01,IEN,10)=+$GET(LRCDT,$$NOW^XLFDT)
+7 SET LRFDA(1,69.01,IEN,12)=DUZ
+8 SET LRFDA(1,69.01,IEN,13)="C"
+9 IF $GET(LRPL)
SET LRFDA(1,69.01,IEN,25)=+$GET(LRPL)
+10 SET LRFDA(1,69.01,IEN,20)=LRNT
+11 DO UPDATE^DIE("KS","LRFDA(1)","IEN","ERR")
End DoDot:1
+12 ;DD 69.01,13 is incorrect
KILL ^LRO(69,"AA",LRODT_"|"_LRSN)
+13 SET ^LRO(69,"AA",LRORD,LRODT_"|"_LRSN)=""
+14 ;Update status in OR(100,
+15 SET LRORIFN=+$PIECE($GET(^LRO(69,LRODT,1,LRSN,2,1,0)),"^",7)
Begin DoDot:1
+16 SET CONTROL=$SELECT($GET(LRORIFN):"SC",1:"SN")
+17 DO NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
End DoDot:1
+18 QUIT
LR7OFAO ;Update ^LRO(69 with accession data.
+1 ;
+2 KILL IEN,LRFDA,LRFDAIEN,LRMSG,DIERR
+3 SET IEN="?+1,"_LRSN_","_LRODT_","
+4 SET LRFDA(6,69.03,IEN,.01)=LRTST
+5 IF $GET(LROUTINE)
SET LRFDA(6,69.03,IEN,1)=LROUTINE
+6 SET LRFDA(6,69.03,IEN,2)=LRAD
+7 SET LRFDA(6,69.03,IEN,3)=LRAA
+8 SET LRFDA(6,69.03,IEN,4)=LRAN
+9 SET LRFDA(6,69.03,IEN,13)=LRUID
+10 SET LRFDA(6,69.03,IEN,8)="IP"
+11 SET LRFDA(6,69.03,IEN,9)="L"
+12 DO UPDATE^DIE("","LRFDA(6)","LRFDAIEN","LRMSG")
+13 QUIT
DIS63(LRDFN,LRSS,LRIDT) ;Display ^LR(LRDFN,LRSS,LRIDT data
+1 if '$GET(^LR(LRDFN,LRSS,LRIDT,0))
QUIT
+2 WRITE @IOF,!!,$$CJ^XLFSTR("-------------------------------------",IOM),!
+3 WRITE $$CJ^XLFSTR("Display of CPRS data in LAB DATA file",IOM),!
+4 NEW ANS,DIC,DA,DR,ERR,CNT,ID,IEN,LREND,LRFILE,LRPAGE,S
+5 SET DA=LRIDT
SET DA(1)=LRDFN
SET LREND=0
+6 SET DIC="^LR("_LRDFN_","_""""_LRSS_""""_","
SET DR=0
SET S=1
+7 DO EN^DIQ
SET LRPAGE=S
+8 SET LRFILE=$SELECT(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:0)
+9 SET IEN=DA_","_DA(1)_","
+10 DO GETS^DIQ(LRFILE,IEN,".01:16","ERRZ","ANS","ERR")
+11 FOR ID="BRIEF CLINICAL HISTORY","PREOPERATIVE DIAGNOSIS","OPERATIVE FINDINGS","POSTOPERATIVE DIAGNOSIS"
if $GET(LREND)
QUIT
Begin DoDot:1
+12 IF $ORDER(ANS(LRFILE,IEN,ID,0))
WRITE !?5,ID_":"
DO PAGE
if $GET(LREND)
QUIT
Begin DoDot:2
+13 SET CNT=0
FOR
SET CNT=$ORDER(ANS(LRFILE,IEN,ID,CNT))
if CNT<1!($GET(LREND))
QUIT
Begin DoDot:3
+14 WRITE !,ANS(LRFILE,IEN,ID,CNT,0)
DO PAGE
End DoDot:3
End DoDot:2
End DoDot:1
+15 if '$GET(LREND)
WRITE !!,$$CJ^XLFSTR("--- End of CPRS data in LAB DATA file ---",IOM),!
+16 ;
+17 ; VistA Imaging changes - P509 PMK 5/10/17
+18 ; add case to file #2005.42
IF $TEXT(ADD^MAGTP005)'=""
DO ADD^MAGTP005(LRAC)
+19 ; LRI is used in MAGT7MA instead of LRIDT
NEW LRI
SET LRI=LRIDT
+20 ; invoke Imaging HL7 routine
IF $TEXT(NEW^MAGT7MA)'=""
DO NEW^MAGT7MA
+21 QUIT
+22 ;
SPEC63(LRDFN,LRSS,LRIDT,LRAPSPEC) ;Load AP Specimens into ^LR(
+1 ; INPUT LRAPSPEC(1)="CERVICAL CYTOLOGIC MATERIAL,Thin Prep^^^^^6242^55"
+2 ;
+3 KILL LRFDA,IEN,IENX,ERR,ERR2,WPIEN68,NODE,ANS,ANSY,LRSP,LRCOL
+4 KILL LRJ,NODE,LRFILE,LRSPCOM,LRSPEC,LRSAMP
+5 ;
+6 if LRSS="AU"!(LRSS="BB")
QUIT
+7 SET LRFILE=$SELECT(LRSS="SP":63.812,LRSS="CY":63.902,LRSS="EM":63.202,1:0)
+8 SET IEN="+1,"_LRIDT_","_LRDFN_","
+9 if '$GET(IENX)
SET IENX=0
FOR
SET IENX=$ORDER(LRAPSPEC(IENX))
if IENX<1
QUIT
Begin DoDot:1
+10 SET NODE=LRAPSPEC(IENX)
SET LRSPCOM=$PIECE(NODE,U)
SET LRSPEC=+$PIECE(NODE,U,6)
SET LRSAMP=$PIECE(NODE,U,7)
+11 if $SELECT('LRSPEC
QUIT
+12 KILL LRFDA,ERR,ANSY
+13 ;Specimen Description
SET LRFDA(2,LRFILE,IEN,.01)=LRSPCOM
+14 ;Specimen ^LAB(61,LRSP
SET LRFDA(2,LRFILE,IEN,.06)=LRSPEC
+15 ; Collection Sample ^LAB(62,LRCOL
SET LRFDA(2,LRFILE,IEN,.07)=LRSAMP
+16 DO UPDATE^DIE("KS","LRFDA(2)","ANSY(1)","ERR")
End DoDot:1
+17 QUIT
LRCOM(LRDFN,LRSS,LRIDT,LRCOM) ;Store Comments into ^LR(
+1 ;IN LRCOM(1)="~For Test: GYNECOLOGY"
+2 KILL LRFILE,LRFDA,IEN,CNT
+3 SET LRFILE=$SELECT(LRSS="CH":63.041,LRSS="MI":63.05,LRSS="SP":63.98,LRSS="CY":63.908,LRSS="EM":63.208,1:"")
+4 if 'LRFILE
QUIT
+5 SET IEN="+1,"_LRIDT_","_LRDFN_","
SET CNT=0
+6 FOR
SET CNT=$ORDER(LRCOM(CNT))
if CNT<1
QUIT
Begin DoDot:1
+7 KILL LRFDA,ERR
+8 SET LRFDA(9,LRFILE,IEN,.01)=LRCOM(CNT)
+9 DO UPDATE^DIE("KS","LRFDA(9)","","ERR")
End DoDot:1
+10 QUIT
CLEAN ;Kill variable
+1 QUIT
WKLD ;Setup workload info
+1 ;
+2 NEW LR,LRI,LRK,LRRC,LRT,LRW
+3 SET LRI=LRIDT
+4 SET LRRC=$SELECT($GET(LRCDT):LRCDT,1:$$NOW^XLFDT)
+5 SET LRCAPA=$PIECE(^LAB(69.9,1,0),"^",14)&($PIECE(^LRO(68,LRAA,0),"^",16))
+6 ;
+7 SET LR("L")=LRSS_"^LRAP"
IF LRCAPA
IF "AUSP"[LRSS
SET X=$SELECT(LRSS="SP":"H & E STAIN",1:"AUTOPSY H & E")
DO X^LRUWK
IF $DATA(X)
SET LRW("H&E")=LRT
DO ^LRAPSWK
+8 ;
+9 IF LRCAPA
IF LRSS="EM"
SET X="THICK SECTION EM"
DO X^LRUWK
IF $DATA(X)
SET X=11
DO SET1
SET LRW("SS")=LRT_U_X
SET X="GRID EM"
DO X^LRUWK
IF $DATA(X)
SET X=12
DO SET1
SET LRW("G")=LRT_U_X
DO ^LRAPSWK
+10 ;
+11 IF LRCAPA
Begin DoDot:1
+12 KILL LRT
SET LRT=0
FOR
SET LRT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT))
if LRT<1
QUIT
Begin DoDot:2
+13 if $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,2)>49
QUIT
+14 IF LRSS="CY"
DO ^LRAPCWK
+15 IF LRSS?1(1"SP",1"EM")
DO ^LRAPSWK
DO ^LRSPGD
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT
SET1 SET X=$PIECE($GET(^LRO(69.2,LRAA,0)),"^",X)
if 'X
SET X=1
+1 QUIT
PAGE ;Page Prompt
+1 if $EXTRACT(IOST,1)'="C"
QUIT
+2 SET LRPAGE=$GET(LRPAGE)+1
SET LREND=0
if LRPAGE<(IOSL-2)
QUIT
+3 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $GET(Y)=0
SET LREND=1
QUIT
+4 SET LRPAGE=2
WRITE @IOF
+5 QUIT
+6 ;
UNLOCK ;
+1 IF $GET(LRORD)'=""
LOCK -^LRO(69,"C",LRORD)
+2 QUIT
