LRMIEDZ2 ;DALIO/JMC - MICROBIOLOGY EDIT ROUTINE; May 24, 2021@14:40
;;5.2;LAB SERVICE;**23,104,242,295,350,427,474,536,547,561**;Sep 27, 1994;Build 2
;
; from LRFAST,LRMIEDZ,LRVER
;
; Reference to ^DIE in ICR #5002
;
PAT ;
N LRUID
;
I '$D(LRAN) S LRAN=""
F S:LRAN="" LRAN=$$ACCPRMPT(LRAA,LRAD) Q:LRAN<0 D
. I +LRAN=0 D Q
. . D QUES
. . S LRAN=""
. ;
. S LRANOK=1
. S LRCAPOK=1
. D PAT1
. L -^LR(LRDFN,"MI",LRIDT)
. D LEDI^LRVR0
. K LRTS
. I LRCAPOK&($P(LRPARAM,U,14)) D ^LRCAPV1
. S LRAN=""
;
;
Q
;
;
ACCPRMPT(LRAA,LRAD) ;Prompt for accession number or UID
;
; Call with LRAA = Accession Area
; LRAD = Accession Date
;
; Accession number/UID entered must have the same accession
; area and date as LRAA and LRAD
;
; Returns LRAN = 0 (not valid input)
; = -1 (user wants to exit - they entered up-arrow, pressed the Enter/Return key, or timed out)
; = >0 (valid accession number)
;
N DIR,DIRUT,DTOUT,DUOUT,LRAN,LRANOK,LRX,LRY,X,Y
;
S LRAN=0
;
W !!
;
S DIR(0)="FO^1:30",DIR("A")="Select MICROBIOLOGY Accession or UID"
S DIR("?")="^D QUES^LRMIEDZ2"
D ^DIR
I Y=""!$D(DIRUT) Q -1
S LRX=Y
;
S:$L(LRX)>2 ^DISV(DUZ,"LRACC")=LRX
S:LRX=" " LRX=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
;
I $D(^LRO(68,"C",LRX)) D Q LRAN
. S LRY=$$CHECKUID^LRWU4(LRX,"MI")
. I 'LRY Q
. I $P(LRY,U,2)'=LRAA!($P(LRY,U,3)'=LRAD) Q
. S LRAN=$P(LRY,U,4)
. W " (",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
;
S LRANOK=1
S X=LRX
D LRANX^LRMIU4
I 'LRANOK S LRAN=0
;
Q LRAN
;
;
QUES ;
;
W $C(7),!,"Enter the accession number or the unique identifier (UID)."
W !,"If entering the accession number, enter just the number portion."
W !,?5," e.g., if the accession is MICRO 13 30173, enter 30173."
W !,?5," Only accessions from subscript MI are selectable."
W !,"If entering the UID, enter the entire 10-15 characters."
W !
W !,"The accession number/UID entered must have the same accession"
W !,"area and date as the first accession entered."
;
Q
;
;
PAT1 ; Called from above and LRFAST
;
; Set LRANOK if called from LRFAST and not set
I $G(LRANOK)="" N LRANOK S LRANOK=1
;
S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
S LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5),LRCDT=+^(3),LREAL=$P(^(3),U,2),LRI=+$O(^(5,0)),LRSPEC=$S($D(^(LRI,0)):+^(0),1:"")
;
I '$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) D Q
. W !,"No tests associated with this accession" S LRANOK=0
. Q:$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))," ")=$P(^LRO(68,LRAA,0),U,11)
. W !,"Verify with accession #: ",$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
;
; Insure DILOCKTM is defined
I $G(DILOCKTM)="" D
. N DIQUIET
. S DIQUIET=1 D DT^DICRW
;
L +^LR(LRDFN,"MI",LRIDT):DILOCKTM
I '$T W !!?10,"Someone else is editing this accession ",!,$C(7) S LRANOK=0 Q
I '$D(^LR(LRDFN,"MI",LRIDT,0)) D BB S (LRCAPOK,LRANOK)=0 Q
S (LRBG0,Y(0))=^LR(LRDFN,"MI",LRIDT,0)
;
D PATINFO
;
I $$GET^XPAR("USR^DIV^PKG","LR MI VERIFY DISPLAY PROVIDER",1,"Q") D PROV
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT
I $P(^LR(LRDFN,"MI",LRIDT,0),U,3) D
. S DIR("A",1)="Final report has been verified by microbiology supervisor."
. S DIR("A",2)="If you proceed in editing, this report will need to be reverified."
. S DIR("B")="NO"
E S DIR("B")="YES"
S DIR(0)="YO",DIR("A")="Edit this accession"
D ^DIR
I Y<1 S (LRCAPOK,LRANOK)=0 D ASKXQA W ! Q
;
;
AUDRTN ;
; Also called from LRVR0 when verifying Lab UI instrument results and user wants to do full edit.
;
N LRAMX,LRUNDO
S (LRAMX,LRUNDO)=0
;LRAMX = results amended after supervisor verification
I $P(^LR(LRDFN,"MI",LRIDT,0),U,3)!$P(^LR(LRDFN,"MI",LRIDT,0),U,9) S (LRUNDO,LRAMX)=1
;
D EC^LRMIEDZ4
I N=0 W !,"No Tests on Accession" S (LRCAPOK,LRANOK)=0 Q
I '$D(LRNPTP) D
. I N=1 S LRI=1 Q
. N DIR,DIROUT,DIRUT,DTOUT,DUOUT
. S DIR(0)="NO^1:"_N_":0",DIR("A")="Select Test",DIR("B")=1
. D ^DIR
. I Y<1 S (LRCAPOK,LRANOK)=0 Q
. S LRI=Y
I LRANOK=0 Q
I LRTX(LRI)="" W !,"EDIT CODE IN FILE 60 NOT DEFINED.",! S (LRCAPOK,LRANOK)=0 Q
;
S LRTS=LRTS(LRI)
K DR
S DA=LRIDT,DA(1)=LRDFN,DIE="^LR(LRDFN,""MI"","
;
S LRSB=$S(LRTX(LRI)["11.5":1,LRTX(LRI)["23":11,LRTX(LRI)["19":8,LRTX(LRI)["15":5,LRTX(LRI)["34":16,1:"")
;LR*5.2*536 add check for the Microbiology area's "date approved" field
;for results which may have previously been verified.
;Variable LRSB indicates the appropriate Microbiology area
;Subscripts: 1 = Bacteriology; 5=Parasitology; 8=Mycology; 11=TB; 16=Virology
I LRSB]"",$P($G(^LR(LRDFN,"MI",LRIDT,LRSB)),U) S LRUNDO=1
;LR*5.2*547 - User must acknowledge that the RPT DATE APPROVED prompt
; will be re-entered in order for results to be viewable in CPRS.
N LRQUITX
S LRQUITX=0
;do not ask question if using instrumentation logic (i.e. LREDITTYPE=3)
I LRUNDO,$G(LREDITTYPE)'=3 D
. N DIR,DTOUT,DUTOUT,Y
. W !,"WARNING: Results have previously been verified."
. W !," If you proceed, a new RPT DATE APPROVED MUST be re-entered,"
. W !," so results are viewable in CPRS.",!
. W !,"Exiting early will cause results not to be viewable in CPRS.",!
. S DIR("A")="Do you wish to edit the accession and re-enter RPT DATE APPROVED"
. S DIR(0)="YN"
. S DIR("B")="NO"
. D ^DIR
. I $D(DTOUT)!($D(DUOUT))!($G(Y)<1) D Q
. . S (LRCAPOK,LRANOK)=0
. . S LRQUITX=1
Q:LRQUITX
;end of LR*5.2*547
D:LRUNDO UNDO
S LRFIFO=LRTX(LRI)["FIFO",(LREND,LRSAME)=0 D:'LRFIFO TIME^LRMIEDZ3 I LREND K DR Q
;
S LRSSC=$P(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$P(^(0),U,11)
;
;
AUDPT ;
; Check for "B" x-ref on #.01 field.
F I=3,6,9,12,17 I $D(^LR(LRDFN,"MI",LRIDT,I)),'$D(^LR(LRDFN,"MI",LRIDT,I,"B")) D SETBINDX^LRMIBUG(LRDFN,LRIDT,I)
;
I $D(LRLEDI) Q
;
; Set Y(0) for backward compatibility
S Y(0)=LRBG0
;
; Execute code does not contain an edit template but fields/code
I LRTX(LRI)'["S DR=""[",LRSB D Q
. X LRTX(LRI)
. ;LR*5.2*547: Kill ^XTMP("LRMICRO EDIT" since report was verified.
. I $P($G(^LR(LRDFN,"MI",LRIDT,LRSB)),"^")]"" D
. . K ^XTMP("LRMICRO EDIT",LRDFN,LRIDT,LRSB)
. I $G(LREDITTYPE)=3 Q ; If called from LRVR0 then return to complete post actions.
. D EDIT^LRRPLU(LRDFN,LRSS,LRIDT) ; performing lab
. D UPDATE^LRPXRM(LRDFN,"MI",LRIDT) ; clinical reminders
. D:'LREND EC3 K DR
. D:LRUNDO&$P($G(^LR(LRDFN,"MI",LRIDT,LRSB)),U)'="" VT^LRMIUT1
. D ASKXQA ; ask CPRS alerts
;
; Execute code contains an edit template name
S (X,DR)=$P($P(LRTX(LRI),"[",2),"]",1) S:X'="" X=+$O(^DIE("B",X,0)) I X<1,'$D(^DIE(+X,"DR",2,63.05)) W !,DR," template doesn't exist for Microbiology." K DR Q
S J=1 F S J=+$O(^DIE(X,"DR",J)) Q:J<1 S K=+$O(^DIE(X,"DR",J,0)),DR(J-1,K)=^DIE(X,"DR",J,K)
S DR=DR(1,63.05)
D ^DIE
;LR*5.2*547: Kill ^XTMP("LRMICRO EDIT" since report was verified.
I $P($G(^LR(LRDFN,"MI",LRIDT,LRSB)),"^")]"" D
. K ^XTMP("LRMICRO EDIT",LRDFN,LRIDT,LRSB)
;
; If called from LRVR0 then return to complete post actions.
I $G(LREDITTYPE)=3 Q
;
; Ask for performing laboratory assignment
D EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
;
; Call clincial reminders
D UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
;
D EC3
;
; Ask to send CPRS alert
D ASKXQA
;
K DR
Q
;
UNDO ;LR*5.2*536 version of UNDO
;Null out the "RPT DATE APPROVED" field so that unverified results are not visible in CPRS
I $G(LRSB)]"",$P($G(^LR(LRDFN,"MI",LRIDT,LRSB)),U) S $P(^LR(LRDFN,"MI",LRIDT,LRSB),U)=""
S $P(^LR(LRDFN,"MI",LRIDT,0),U,3,4)=U
;LR*5.2*547: Set ^XTMP("LRMICRO EDIT" so that CPRS and VistA reports will display
; an informational message that the accession/test is being edited and
; results are not available for viewing at this time.
; Cannot rely on a null first piece at ^LR(LRDFN,"MI",LRIDT,LRSB) because
; not all sub-areas (esp. Virology) have the prelim/final flag set
; as required.
S ^XTMP("LRMICRO EDIT",LRDFN,LRIDT,LRSB)=DUZ
;Re-set the purge date so that background processes won't kill this subscript until six
;months have passed when no more Microbiology result verification is being performed in VistA.
S ^XTMP("LRMICRO EDIT",0)=$$FMADD^XLFDT(DT,180)_"^"_DT_" Microbiology accessions which are being edited"
;LR*5.2*536:
; After discussion with Tier 2, it was decided to preserve the settings in file 68 fields
; Saving the lines below commented out in case this decision changes in the future.
; S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)=""
; S $P(^LRO(68,LRAA,1,LRAD,1,+LRAN,4,LRTS,0),U,4,5)=U
;only set amended report flag if results were previously released by a supervisor
I LRAMX S $P(^LR(LRDFN,"MI",LRIDT,0),U,9)=1
D UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
Q
;
BB ;
W !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",!
Q
;
;
EC3 ;
S LRSSCN=$P(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$P(^(0),U,11)
D:LRSSCN'=LRSSC UPDATE
K LRSSCN,LRSSC S LRSAME=1
;LR*5.2*561: If verifying LEDI results and status is not final,
; do not automatically populate complete date/time.
; (LRINTYPE=10 indicates LEDI.)
N LRXSB,LRXQUIT
S LRXQUIT=0
I $G(LRINTYPE)=10,$G(LRI),$D(LRTX(LRI)) D
. S LRXSB=$S(LRTX(LRI)["11.5":1,LRTX(LRI)["23":11,LRTX(LRI)["19":8,LRTX(LRI)["15":5,LRTX(LRI)["34":16,1:"")
. Q:LRXSB=""
. I $D(^LR(LRDFN,"MI",LRIDT,LRXSB)),$P(^LR(LRDFN,"MI",LRIDT,LRXSB),"^",2)'="F" S LRXQUIT=1
I 'LRXQUIT D TIME^LRMIEDZ3
D:'LREND STF^LRMIUT
Q
;
;
UPDATE ;
D CHECK
K LRSSCOM,LRSSCOM1,LRSSCA,LRSSCAA,LRSSCAY,LRSSCAN,LRSSCOD,LRSSCON
Q
;
;
CHECK ;
S LRSSCA=$P(^LR(LRDFN,"MI",LRIDT,0),U,6),LRSSCAA=+$O(^LRO(68,"B",$P(LRSSCA," "),0))
S X=$P(LRSSCA," ",2) D ^%DT S LRSSCAY=Y,LRSSCAN=$P(LRSSCA," ",3)
S J=0 F S J=+$O(^LRO(68,LRSSCAA,1,LRSSCAY,1,LRSSCAN,5,J)) Q:J<1 I ^(J,0)=LRSSC S ^(0)=LRSSCN Q
I J<1 Q
S LRSSCOD=$P(^LRO(68,LRSSCAA,1,LRSSCAY,1,LRSSCAN,0),U,4),LRSSCON=^(.1)
S J=0 F S J=+$O(^LRO(69,LRSSCOD,1,J)) Q:J<1 I $D(^(J,.1)),^(.1)=LRSSCON D ORDER Q
Q
;
;
ORDER ;
S $P(^LRO(69,LRSSCOD,1,J,0),U,3)=$P(LRSSCN,U,2)
S K=0 F S K=+$O(^LRO(69,LRSSCOD,1,J,4,K)) Q:K<1 I ^(K,0)=LRSSC S ^(0)=LRSSCN Q
Q
;
;
PATINFO ; Display patient information
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRUNDO=0
D PT^LRX
W !!,?5,PNM," SSN: ",SSN
I LRDPF=2 W " LOC: ",$S(LRWRD'="":LRWRD,1:$S($D(^LR(LRDFN,.1)):^(.1),1:"??")),!
;
I LRDPF?1(1"62.3",1"67.2",1"67.3",1"67.4") Q
;
W !,"Pat Info: ",$P($G(^LR(LRDFN,.091)),U)
W ?34," Sex: ",$S(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
W ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
Q
;
;
PROV ; Display provider and contact numbers.
N LRPRAC,LRX
S LRPRAC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,8)
I LRPRAC>0,LRPRAC=+LRPRAC D GETS^DIQ(200,LRPRAC_",",".01;.132;.137;.138","E","LRPRAC(LRPRAC)","LRERR")
;
W !,"Provider: "
;
I LRPRAC,$D(LRPRAC(LRPRAC,200)) D Q
. W LRPRAC(LRPRAC,200,LRPRAC_",",.01,"E"),?40," Voice pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.137,"E")
. W !," Phone: ",LRPRAC(LRPRAC,200,LRPRAC_",",.132,"E"),?38," Digital pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.138,"E")
;
S LRX=""
I LRPRAC?1"REF:"1.AN!(LRDPF=67) S LRX=$$REFDOC^LRRP1(LRDFN,LRSS,LRIDT)
I LRX'="" W LRX
E W LRPRAC
;
Q
;
;
ASKXQA ; Determine if user should be ask to send CPRS Alert
;
N LRDEFAULT
;
; No CPRS alert for non-PATIENT file (#2) patients
I +LRDPF'=2 Q
;
S LRDEFAULT=$$GET^XPAR("USR^DIV^PKG","LR MI VERIFY CPRS ALERT",1,"Q")
I LRDEFAULT>0 D ASKXQA^LR7ORB3(LRDFN,"MI",LRIDT,LRUID,LRDEFAULT)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIEDZ2 11753 printed Apr 09, 2024@21:25:46 Page 2
LRMIEDZ2 ;DALIO/JMC - MICROBIOLOGY EDIT ROUTINE; May 24, 2021@14:40
+1 ;;5.2;LAB SERVICE;**23,104,242,295,350,427,474,536,547,561**;Sep 27, 1994;Build 2
+2 ;
+3 ; from LRFAST,LRMIEDZ,LRVER
+4 ;
+5 ; Reference to ^DIE in ICR #5002
+6 ;
PAT ;
+1 NEW LRUID
+2 ;
+3 IF '$DATA(LRAN)
SET LRAN=""
+4 FOR
if LRAN=""
SET LRAN=$$ACCPRMPT(LRAA,LRAD)
if LRAN<0
QUIT
Begin DoDot:1
+5 IF +LRAN=0
Begin DoDot:2
+6 DO QUES
+7 SET LRAN=""
End DoDot:2
QUIT
+8 ;
+9 SET LRANOK=1
+10 SET LRCAPOK=1
+11 DO PAT1
+12 LOCK -^LR(LRDFN,"MI",LRIDT)
+13 DO LEDI^LRVR0
+14 KILL LRTS
+15 IF LRCAPOK&($PIECE(LRPARAM,U,14))
DO ^LRCAPV1
+16 SET LRAN=""
End DoDot:1
+17 ;
+18 ;
+19 QUIT
+20 ;
+21 ;
ACCPRMPT(LRAA,LRAD) ;Prompt for accession number or UID
+1 ;
+2 ; Call with LRAA = Accession Area
+3 ; LRAD = Accession Date
+4 ;
+5 ; Accession number/UID entered must have the same accession
+6 ; area and date as LRAA and LRAD
+7 ;
+8 ; Returns LRAN = 0 (not valid input)
+9 ; = -1 (user wants to exit - they entered up-arrow, pressed the Enter/Return key, or timed out)
+10 ; = >0 (valid accession number)
+11 ;
+12 NEW DIR,DIRUT,DTOUT,DUOUT,LRAN,LRANOK,LRX,LRY,X,Y
+13 ;
+14 SET LRAN=0
+15 ;
+16 WRITE !!
+17 ;
+18 SET DIR(0)="FO^1:30"
SET DIR("A")="Select MICROBIOLOGY Accession or UID"
+19 SET DIR("?")="^D QUES^LRMIEDZ2"
+20 DO ^DIR
+21 IF Y=""!$DATA(DIRUT)
QUIT -1
+22 SET LRX=Y
+23 ;
+24 if $LENGTH(LRX)>2
SET ^DISV(DUZ,"LRACC")=LRX
+25 if LRX=" "
SET LRX=$SELECT($DATA(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
+26 ;
+27 IF $DATA(^LRO(68,"C",LRX))
Begin DoDot:1
+28 SET LRY=$$CHECKUID^LRWU4(LRX,"MI")
+29 IF 'LRY
QUIT
+30 IF $PIECE(LRY,U,2)'=LRAA!($PIECE(LRY,U,3)'=LRAD)
QUIT
+31 SET LRAN=$PIECE(LRY,U,4)
+32 WRITE " (",$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
End DoDot:1
QUIT LRAN
+33 ;
+34 SET LRANOK=1
+35 SET X=LRX
+36 DO LRANX^LRMIU4
+37 IF 'LRANOK
SET LRAN=0
+38 ;
+39 QUIT LRAN
+40 ;
+41 ;
QUES ;
+1 ;
+2 WRITE $CHAR(7),!,"Enter the accession number or the unique identifier (UID)."
+3 WRITE !,"If entering the accession number, enter just the number portion."
+4 WRITE !,?5," e.g., if the accession is MICRO 13 30173, enter 30173."
+5 WRITE !,?5," Only accessions from subscript MI are selectable."
+6 WRITE !,"If entering the UID, enter the entire 10-15 characters."
+7 WRITE !
+8 WRITE !,"The accession number/UID entered must have the same accession"
+9 WRITE !,"area and date as the first accession entered."
+10 ;
+11 QUIT
+12 ;
+13 ;
PAT1 ; Called from above and LRFAST
+1 ;
+2 ; Set LRANOK if called from LRFAST and not set
+3 IF $GET(LRANOK)=""
NEW LRANOK
SET LRANOK=1
+4 ;
+5 SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
+6 SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+7 SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
SET LRCDT=+^(3)
SET LREAL=$PIECE(^(3),U,2)
SET LRI=+$ORDER(^(5,0))
SET LRSPEC=$SELECT($DATA(^(LRI,0)):+^(0),1:"")
+8 ;
+9 IF '$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
Begin DoDot:1
+10 WRITE !,"No tests associated with this accession"
SET LRANOK=0
+11 if $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))," ")=$PIECE(^LRO(68,LRAA,0),U,11)
QUIT
+12 WRITE !,"Verify with accession #: ",$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
End DoDot:1
QUIT
+13 ;
+14 ; Insure DILOCKTM is defined
+15 IF $GET(DILOCKTM)=""
Begin DoDot:1
+16 NEW DIQUIET
+17 SET DIQUIET=1
DO DT^DICRW
End DoDot:1
+18 ;
+19 LOCK +^LR(LRDFN,"MI",LRIDT):DILOCKTM
+20 IF '$TEST
WRITE !!?10,"Someone else is editing this accession ",!,$CHAR(7)
SET LRANOK=0
QUIT
+21 IF '$DATA(^LR(LRDFN,"MI",LRIDT,0))
DO BB
SET (LRCAPOK,LRANOK)=0
QUIT
+22 SET (LRBG0,Y(0))=^LR(LRDFN,"MI",LRIDT,0)
+23 ;
+24 DO PATINFO
+25 ;
+26 IF $$GET^XPAR("USR^DIV^PKG","LR MI VERIFY DISPLAY PROVIDER",1,"Q")
DO PROV
+27 ;
+28 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
+29 IF $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,3)
Begin DoDot:1
+30 SET DIR("A",1)="Final report has been verified by microbiology supervisor."
+31 SET DIR("A",2)="If you proceed in editing, this report will need to be reverified."
+32 SET DIR("B")="NO"
End DoDot:1
+33 IF '$TEST
SET DIR("B")="YES"
+34 SET DIR(0)="YO"
SET DIR("A")="Edit this accession"
+35 DO ^DIR
+36 IF Y<1
SET (LRCAPOK,LRANOK)=0
DO ASKXQA
WRITE !
QUIT
+37 ;
+38 ;
AUDRTN ;
+1 ; Also called from LRVR0 when verifying Lab UI instrument results and user wants to do full edit.
+2 ;
+3 NEW LRAMX,LRUNDO
+4 SET (LRAMX,LRUNDO)=0
+5 ;LRAMX = results amended after supervisor verification
+6 IF $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,3)!$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,9)
SET (LRUNDO,LRAMX)=1
+7 ;
+8 DO EC^LRMIEDZ4
+9 IF N=0
WRITE !,"No Tests on Accession"
SET (LRCAPOK,LRANOK)=0
QUIT
+10 IF '$DATA(LRNPTP)
Begin DoDot:1
+11 IF N=1
SET LRI=1
QUIT
+12 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
+13 SET DIR(0)="NO^1:"_N_":0"
SET DIR("A")="Select Test"
SET DIR("B")=1
+14 DO ^DIR
+15 IF Y<1
SET (LRCAPOK,LRANOK)=0
QUIT
+16 SET LRI=Y
End DoDot:1
+17 IF LRANOK=0
QUIT
+18 IF LRTX(LRI)=""
WRITE !,"EDIT CODE IN FILE 60 NOT DEFINED.",!
SET (LRCAPOK,LRANOK)=0
QUIT
+19 ;
+20 SET LRTS=LRTS(LRI)
+21 KILL DR
+22 SET DA=LRIDT
SET DA(1)=LRDFN
SET DIE="^LR(LRDFN,""MI"","
+23 ;
+24 SET LRSB=$SELECT(LRTX(LRI)["11.5":1,LRTX(LRI)["23":11,LRTX(LRI)["19":8,LRTX(LRI)["15":5,LRTX(LRI)["34":16,1:"")
+25 ;LR*5.2*536 add check for the Microbiology area's "date approved" field
+26 ;for results which may have previously been verified.
+27 ;Variable LRSB indicates the appropriate Microbiology area
+28 ;Subscripts: 1 = Bacteriology; 5=Parasitology; 8=Mycology; 11=TB; 16=Virology
+29 IF LRSB]""
IF $PIECE($GET(^LR(LRDFN,"MI",LRIDT,LRSB)),U)
SET LRUNDO=1
+30 ;LR*5.2*547 - User must acknowledge that the RPT DATE APPROVED prompt
+31 ; will be re-entered in order for results to be viewable in CPRS.
+32 NEW LRQUITX
+33 SET LRQUITX=0
+34 ;do not ask question if using instrumentation logic (i.e. LREDITTYPE=3)
+35 IF LRUNDO
IF $GET(LREDITTYPE)'=3
Begin DoDot:1
+36 NEW DIR,DTOUT,DUTOUT,Y
+37 WRITE !,"WARNING: Results have previously been verified."
+38 WRITE !," If you proceed, a new RPT DATE APPROVED MUST be re-entered,"
+39 WRITE !," so results are viewable in CPRS.",!
+40 WRITE !,"Exiting early will cause results not to be viewable in CPRS.",!
+41 SET DIR("A")="Do you wish to edit the accession and re-enter RPT DATE APPROVED"
+42 SET DIR(0)="YN"
+43 SET DIR("B")="NO"
+44 DO ^DIR
+45 IF $DATA(DTOUT)!($DATA(DUOUT))!($GET(Y)<1)
Begin DoDot:2
+46 SET (LRCAPOK,LRANOK)=0
+47 SET LRQUITX=1
End DoDot:2
QUIT
End DoDot:1
+48 if LRQUITX
QUIT
+49 ;end of LR*5.2*547
+50 if LRUNDO
DO UNDO
+51 SET LRFIFO=LRTX(LRI)["FIFO"
SET (LREND,LRSAME)=0
if 'LRFIFO
DO TIME^LRMIEDZ3
IF LREND
KILL DR
QUIT
+52 ;
+53 SET LRSSC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$PIECE(^(0),U,11)
+54 ;
+55 ;
AUDPT ;
+1 ; Check for "B" x-ref on #.01 field.
+2 FOR I=3,6,9,12,17
IF $DATA(^LR(LRDFN,"MI",LRIDT,I))
IF '$DATA(^LR(LRDFN,"MI",LRIDT,I,"B"))
DO SETBINDX^LRMIBUG(LRDFN,LRIDT,I)
+3 ;
+4 IF $DATA(LRLEDI)
QUIT
+5 ;
+6 ; Set Y(0) for backward compatibility
+7 SET Y(0)=LRBG0
+8 ;
+9 ; Execute code does not contain an edit template but fields/code
+10 IF LRTX(LRI)'["S DR=""["
IF LRSB
Begin DoDot:1
+11 XECUTE LRTX(LRI)
+12 ;LR*5.2*547: Kill ^XTMP("LRMICRO EDIT" since report was verified.
+13 IF $PIECE($GET(^LR(LRDFN,"MI",LRIDT,LRSB)),"^")]""
Begin DoDot:2
+14 KILL ^XTMP("LRMICRO EDIT",LRDFN,LRIDT,LRSB)
End DoDot:2
+15 ; If called from LRVR0 then return to complete post actions.
IF $GET(LREDITTYPE)=3
QUIT
+16 ; performing lab
DO EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
+17 ; clinical reminders
DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
+18 if 'LREND
DO EC3
KILL DR
+19 if LRUNDO&$PIECE($GET(^LR(LRDFN,"MI",LRIDT,LRSB)),U)'=""
DO VT^LRMIUT1
+20 ; ask CPRS alerts
DO ASKXQA
End DoDot:1
QUIT
+21 ;
+22 ; Execute code contains an edit template name
+23 SET (X,DR)=$PIECE($PIECE(LRTX(LRI),"[",2),"]",1)
if X'=""
SET X=+$ORDER(^DIE("B",X,0))
IF X<1
IF '$DATA(^DIE(+X,"DR",2,63.05))
WRITE !,DR," template doesn't exist for Microbiology."
KILL DR
QUIT
+24 SET J=1
FOR
SET J=+$ORDER(^DIE(X,"DR",J))
if J<1
QUIT
SET K=+$ORDER(^DIE(X,"DR",J,0))
SET DR(J-1,K)=^DIE(X,"DR",J,K)
+25 SET DR=DR(1,63.05)
+26 DO ^DIE
+27 ;LR*5.2*547: Kill ^XTMP("LRMICRO EDIT" since report was verified.
+28 IF $PIECE($GET(^LR(LRDFN,"MI",LRIDT,LRSB)),"^")]""
Begin DoDot:1
+29 KILL ^XTMP("LRMICRO EDIT",LRDFN,LRIDT,LRSB)
End DoDot:1
+30 ;
+31 ; If called from LRVR0 then return to complete post actions.
+32 IF $GET(LREDITTYPE)=3
QUIT
+33 ;
+34 ; Ask for performing laboratory assignment
+35 DO EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
+36 ;
+37 ; Call clincial reminders
+38 DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
+39 ;
+40 DO EC3
+41 ;
+42 ; Ask to send CPRS alert
+43 DO ASKXQA
+44 ;
+45 KILL DR
+46 QUIT
+47 ;
UNDO ;LR*5.2*536 version of UNDO
+1 ;Null out the "RPT DATE APPROVED" field so that unverified results are not visible in CPRS
+2 IF $GET(LRSB)]""
IF $PIECE($GET(^LR(LRDFN,"MI",LRIDT,LRSB)),U)
SET $PIECE(^LR(LRDFN,"MI",LRIDT,LRSB),U)=""
+3 SET $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,3,4)=U
+4 ;LR*5.2*547: Set ^XTMP("LRMICRO EDIT" so that CPRS and VistA reports will display
+5 ; an informational message that the accession/test is being edited and
+6 ; results are not available for viewing at this time.
+7 ; Cannot rely on a null first piece at ^LR(LRDFN,"MI",LRIDT,LRSB) because
+8 ; not all sub-areas (esp. Virology) have the prelim/final flag set
+9 ; as required.
+10 SET ^XTMP("LRMICRO EDIT",LRDFN,LRIDT,LRSB)=DUZ
+11 ;Re-set the purge date so that background processes won't kill this subscript until six
+12 ;months have passed when no more Microbiology result verification is being performed in VistA.
+13 SET ^XTMP("LRMICRO EDIT",0)=$$FMADD^XLFDT(DT,180)_"^"_DT_" Microbiology accessions which are being edited"
+14 ;LR*5.2*536:
+15 ; After discussion with Tier 2, it was decided to preserve the settings in file 68 fields
+16 ; Saving the lines below commented out in case this decision changes in the future.
+17 ; S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)=""
+18 ; S $P(^LRO(68,LRAA,1,LRAD,1,+LRAN,4,LRTS,0),U,4,5)=U
+19 ;only set amended report flag if results were previously released by a supervisor
+20 IF LRAMX
SET $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,9)=1
+21 DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
+22 QUIT
+23 ;
BB ;
+1 WRITE !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",!
+2 QUIT
+3 ;
+4 ;
EC3 ;
+1 SET LRSSCN=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)_U_$PIECE(^(0),U,11)
+2 if LRSSCN'=LRSSC
DO UPDATE
+3 KILL LRSSCN,LRSSC
SET LRSAME=1
+4 ;LR*5.2*561: If verifying LEDI results and status is not final,
+5 ; do not automatically populate complete date/time.
+6 ; (LRINTYPE=10 indicates LEDI.)
+7 NEW LRXSB,LRXQUIT
+8 SET LRXQUIT=0
+9 IF $GET(LRINTYPE)=10
IF $GET(LRI)
IF $DATA(LRTX(LRI))
Begin DoDot:1
+10 SET LRXSB=$SELECT(LRTX(LRI)["11.5":1,LRTX(LRI)["23":11,LRTX(LRI)["19":8,LRTX(LRI)["15":5,LRTX(LRI)["34":16,1:"")
+11 if LRXSB=""
QUIT
+12 IF $DATA(^LR(LRDFN,"MI",LRIDT,LRXSB))
IF $PIECE(^LR(LRDFN,"MI",LRIDT,LRXSB),"^",2)'="F"
SET LRXQUIT=1
End DoDot:1
+13 IF 'LRXQUIT
DO TIME^LRMIEDZ3
+14 if 'LREND
DO STF^LRMIUT
+15 QUIT
+16 ;
+17 ;
UPDATE ;
+1 DO CHECK
+2 KILL LRSSCOM,LRSSCOM1,LRSSCA,LRSSCAA,LRSSCAY,LRSSCAN,LRSSCOD,LRSSCON
+3 QUIT
+4 ;
+5 ;
CHECK ;
+1 SET LRSSCA=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,6)
SET LRSSCAA=+$ORDER(^LRO(68,"B",$PIECE(LRSSCA," "),0))
+2 SET X=$PIECE(LRSSCA," ",2)
DO ^%DT
SET LRSSCAY=Y
SET LRSSCAN=$PIECE(LRSSCA," ",3)
+3 SET J=0
FOR
SET J=+$ORDER(^LRO(68,LRSSCAA,1,LRSSCAY,1,LRSSCAN,5,J))
if J<1
QUIT
IF ^(J,0)=LRSSC
SET ^(0)=LRSSCN
QUIT
+4 IF J<1
QUIT
+5 SET LRSSCOD=$PIECE(^LRO(68,LRSSCAA,1,LRSSCAY,1,LRSSCAN,0),U,4)
SET LRSSCON=^(.1)
+6 SET J=0
FOR
SET J=+$ORDER(^LRO(69,LRSSCOD,1,J))
if J<1
QUIT
IF $DATA(^(J,.1))
IF ^(.1)=LRSSCON
DO ORDER
QUIT
+7 QUIT
+8 ;
+9 ;
ORDER ;
+1 SET $PIECE(^LRO(69,LRSSCOD,1,J,0),U,3)=$PIECE(LRSSCN,U,2)
+2 SET K=0
FOR
SET K=+$ORDER(^LRO(69,LRSSCOD,1,J,4,K))
if K<1
QUIT
IF ^(K,0)=LRSSC
SET ^(0)=LRSSCN
QUIT
+3 QUIT
+4 ;
+5 ;
PATINFO ; Display patient information
+1 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
SET LRUNDO=0
+2 DO PT^LRX
+3 WRITE !!,?5,PNM," SSN: ",SSN
+4 IF LRDPF=2
WRITE " LOC: ",$SELECT(LRWRD'="":LRWRD,1:$SELECT($DATA(^LR(LRDFN,.1)):^(.1),1:"??")),!
+5 ;
+6 IF LRDPF?1(1"62.3",1"67.2",1"67.3",1"67.4")
QUIT
+7 ;
+8 WRITE !,"Pat Info: ",$PIECE($GET(^LR(LRDFN,.091)),U)
+9 WRITE ?34," Sex: ",$SELECT(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
+10 WRITE ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
+11 QUIT
+12 ;
+13 ;
PROV ; Display provider and contact numbers.
+1 NEW LRPRAC,LRX
+2 SET LRPRAC=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,8)
+3 IF LRPRAC>0
IF LRPRAC=+LRPRAC
DO GETS^DIQ(200,LRPRAC_",",".01;.132;.137;.138","E","LRPRAC(LRPRAC)","LRERR")
+4 ;
+5 WRITE !,"Provider: "
+6 ;
+7 IF LRPRAC
IF $DATA(LRPRAC(LRPRAC,200))
Begin DoDot:1
+8 WRITE LRPRAC(LRPRAC,200,LRPRAC_",",.01,"E"),?40," Voice pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.137,"E")
+9 WRITE !," Phone: ",LRPRAC(LRPRAC,200,LRPRAC_",",.132,"E"),?38," Digital pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.138,"E")
End DoDot:1
QUIT
+10 ;
+11 SET LRX=""
+12 IF LRPRAC?1"REF:"1.AN!(LRDPF=67)
SET LRX=$$REFDOC^LRRP1(LRDFN,LRSS,LRIDT)
+13 IF LRX'=""
WRITE LRX
+14 IF '$TEST
WRITE LRPRAC
+15 ;
+16 QUIT
+17 ;
+18 ;
ASKXQA ; Determine if user should be ask to send CPRS Alert
+1 ;
+2 NEW LRDEFAULT
+3 ;
+4 ; No CPRS alert for non-PATIENT file (#2) patients
+5 IF +LRDPF'=2
QUIT
+6 ;
+7 SET LRDEFAULT=$$GET^XPAR("USR^DIV^PKG","LR MI VERIFY CPRS ALERT",1,"Q")
+8 IF LRDEFAULT>0
DO ASKXQA^LR7ORB3(LRDFN,"MI",LRIDT,LRUID,LRDEFAULT)
+9 ;
+10 QUIT
