Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRMIEDZ2

LRMIEDZ2.m

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