BLRCHGPL ; IHS/OIT/MKK - CHANGE PROVIDER AND/OR LOCATION UTILITY ; 07/22/2005 8:05 AM ]
;;5.2;LR;**1020,1021,1022**;September 20, 2007
;;
; Some code cloned from SINGLE^LRWRKLST and then modified
MAIN ; EP
; Temp vars -- discard after routine completes
NEW LRDFN,LRSS,LRAA,LRAD,LRAN,LRIDT,LRAAS
NEW LRODT,LRSN,BLRLOGDA
NEW LRACC,LREND,LRSTOP,LRTSE,LRUNC,LRURG
NEW PROVSTR,LOCSTR,CCN,EDD
NEW PROVGET,LOCGET
NEW NPN,OPN,FDA,STR,ERRS
NEW OLN,ON,NLN,NLNMN
NEW ESIGNODE
;
S ESIGNODE=9009027 ; Node in the ^LR global where E-Sig data resides
;
; Setup array so that info can be gotten quickly
D PEP^BLRCHGPW
;
; Setup standard parameters
D URG^LRX
;
; Loop unil done
F D Q:LREND!LRSTOP
. W !!
. S (LREND,LRUNC,LRSTOP,LRTSE,CCN)=0
. S LRACC=""
. D ^LRWU4 ; Get Lab Data from Accession number
. I LRAN<1 S LREND=1 Q ; If nothing, then set END flag & Quit
. ;
. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q ; Make sure Accession exists
.. W !,"Doesn't exist."
.. D BLRGPGR^BLRGMENU() ; Press "Return" routine
. ;
. ; ----- BEGIN IHS/OIT/MKK MODIFICATION - Patch 1022
. ; If order came from OERR, don't allow change
. NEW LRSP
. S LRSN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
. S LRODT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4) ; Order Date
. S LRSP=+$O(^LRO(69,"C",LRSN,LRODT,""))
. I +$P($G(^LRO(69,LRODT,1,LRSP,0)),"^",11)>0 D Q
.. W !,"Accession is tied to an OERR order. This order cannot be modified.",!
.. D BLRGPGR^BLRGMENU() ; Press "Return" routine
. ; ----- END IHS/OIT/MKK -- MODIFICATION 1022
. ;
. ; Initialization
. K BLRLOGDA
. S LRDFN=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",1)
. S LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
. ;
. D CHNGPROV ; Change Provider?
. I LREND Q ; Quit if END flag set
. D CHNGLOC ; Change Location?
. ;
. ; If all OK, then send changes to PCC via BLR Linker
. ; I 'LREND&($D(BLRLOGDA)) D TOP^BLRQUE(BLRLOGDA,0)
. ; ----- BEGIN IHS/OIT/MKK -- MODIFICATION 1022
. ; All the BLRTXLOG transaction numbers are in the BLRLOGDA array --
. ; have to send over notice about all of them.
. I 'LREND&($D(BLRLOGDA)) D
.. S BLRLOGDA=""
.. F S BLRLOGDA=$O(BLRLOGDA(BLRLOGDA)) Q:BLRLOGDA="" D
... D TOP^BLRQUE(BLRLOGDA,0)
. ; ----- END IHS/OIT/MKK -- MODIFICATION 1022
;
Q
;
; Change Provider? -- Get provider cloned and modified from P^LRWU1
CHNGPROV ;
S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
S OPN=$$GETPHY ; Provider in Lab Data File -- default
;
; If Provider not in Lab Data File, get from Order Entry File
I OPN="" D
. S ON=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
. S LRODT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4) ; Order Date
. S LRSN=$O(^LRO(69,"C",ON,LRODT,"")) ; Order Sequence Number
. S OPN=$P($G(^LRO(69,LRODT,1,LRSN,0)),"^",6) ; Prov from Order Entry
;
D ^XBFMK ; Clear Fileman Variables
S DIC("B")=OPN ; Default is current Provider
S DIC="^VA(200,"
S DIC(0)="AMNEQ"
S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^BLRUTIL2(Y)"
S DIC("A")="PROVIDER: "
S D="AK.PROVIDER"
S DIC("W")="Q"
D ^DIC K DIC
I Y<0 Q ; If Quit or nothing, exit
;
S NPN=+Y
I OPN=NPN Q ; If "Old" = "New" don't bother, just quit
;
; Change the provider in 4 Different files -- quit if LREND=1 (END Flag)
Q:$$SETPLAB ; (1) Lab Data File
Q:$$SETPACC ; (2) Accession File
Q:$$SETPORD ; (3) Order File
; Q:$$SETPTXLG ; (4) IHS Lab Transaction Log (BLRTXLOG)
; ----- BEGIN IHS/OIT/MKK -- MODIFICATION 1022
; Took out code from BLRCHGPL and put into BLRCHGPW because
; BLRCHGPL got too large
Q:$$SETPTXLG^BLRCHGPW ; (4) IHS Lab Transaction Log (BLRTXLOG)
; ----- END IHS/OIT/MKK -- MODIFICATION 1022
;
W !?5,"Provider Change filed",!
;
; Create Audit entry
D SETINDX("PHY",LRAA,LRAD,LRAN,OPN,NPN)
Q
;
GETPHY() ;
Q @$G(PROVGET(LRSS)) ; Return Provider location in file
;
; Change Provider in Lab Data file.
SETPLAB() ;
NEW SUBFILE
D ^XBFMK
K DIE,ERRS,FDA,IENS
S IENS=LRIDT_","_LRDFN_","
S SUBFILE=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01)
S FDA(SUBFILE,IENS,$G(PROVGET(LRSS,0)))=NPN
D FILE^DIE("K","FDA","ERRS")
;
I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("SETPLAB") Q LREND
I $D(ERRS("DIERR"))<1 S LREND=0
;
; D ESIGCHNG ; E-SIG Changes
; ----- BEGIN IHS/OIT/MKK -- MODIFICATION - 1022
; Moved the ESIGCHNG routine from BLRCHGPL to BLRCHGPW because
; BLRCHGPL was getting too large
D ESIGCHNG^BLRCHGPW
; ----- END IHS/OIT/MKK -- MODIFICATION - 1022
;
Q LREND
;
; Change Provider in Accession file.
SETPACC() ;
D ^XBFMK
K DIE,FDA,ERRS,IENS
S IENS=LRAN_","_LRAD_","_LRAA_","
S FDA(68.02,IENS,$G(PROVGET("ACCESSION","PROV")))=NPN
D FILE^DIE("K","FDA","ERRS")
;
I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("SETPACC") Q LREND
I $D(ERRS("DIERR"))<1 S LREND=0
;
Q LREND
;
; Change Provider in Order Entry File
SETPORD() ;
; Order file
NEW DONE
;
S ON=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
S LRODT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4) ; Order Date
;
S (DONE,LRSN)=""
F S LRSN=$O(^LRO(69,"C",ON,LRODT,LRSN)) Q:LRSN=""!(DONE="D") D
. S LRDFN=$P($G(^LRO(69,LRODT,1,LRSN,0)),"^",1)
. S LRTEST=0
. F S LRTEST=$O(^LRO(69,LRODT,1,LRSN,2,LRTEST)) Q:LRTEST=""!(LRTEST'?.N)!(DONE="D") D
.. S TSTSTR=(^LRO(69,LRODT,1,LRSN,2,LRTEST,0))
.. I $P(TSTSTR,"^",3)'=LRODT Q ; If Date doesn't match, skip
.. I $P(TSTSTR,"^",4)'=LRAA Q ; If Accession Area doesn't match, skip
.. I $P(TSTSTR,"^",5)'=LRAN Q ; If Accession Number doesn't match, skip
.. ;
.. ; Accession Matches -- Change Provider
.. S DONE="D" ; No matter what, quit after this
.. D ^XBFMK
.. K DIE,FDA,ERRS,IENS
.. S IENS=LRSN_","_LRODT_","
.. S FDA(69.01,IENS,$G(PROVGET("ORDER ENTRY")))=NPN
.. D FILE^DIE("K","FDA","ERRS")
.. ;
.. I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("SETPORD")
.. I $D(ERRS("DIERR"))<1 S LREND=0
.. ;
.. ; Check to see if Provider REALLY changed
.. I $P($G(^LRO(69,LRODT,1,LRSN,0)),"^",6)'=NPN D Q
... W !!!,?5,$TR($J("",45)," ","*"),!!
... W ?5,$$CJ^XLFSTR("PROVIDER NOT CHANGED IN ORDER FILE",45),!!
... W ?5,"Old Provider IEN:",OPN
... W ?35,"New Prov IEN:",NPN
... W ?5,$TR($J("",45)," ","*"),!!
... S LREND=1
.. ;
.. ; Now, have to change X-Ref since FileMan isn't
.. NEW PTPTR,PATNAME
.. S PTPTR=$P($G(^LR(LRDFN,0)),"^",3)
.. I $G(PTPTR)="" Q
.. ;
.. S PATNAME=$P($G(^DPT(PTPTR,0)),"^",1) ; Patient Name
.. I $G(PATNAME)="" Q
.. ;
.. NEW OPNAME ; "Old" Provider Name"
.. S OPNAME=$P($G(^VA(200,OPN,0)),"^",1)
.. I $D(^LRO(69,LRODT,1,"AP",OPNAME))<1 Q
.. ;
.. NEW IEN,OKNOW,TODT,TON
.. S (IEN,OKNOW)=""
.. I $D(^LRO(69,LRODT,1,"AP",OPNAME,PATNAME,ON))<1 Q
.. ;
.. NEW NPNAME
.. S NPNAME=$P($G(^VA(200,NPN,0)),"^",1)
.. S STR="^LRO(69,"_LRODT_",1,AP,"_OPNAME_","_PATNAME_","_ON_")"
.. K @STR
.. S ^LRO(69,LRODT,1,"AP",NPNAME,PATNAME,ON)=""
;
Q LREND
;
; Populate new global
SETINDX(WOT,LRAA,LRAD,LRAN,OLD,NEW) ;
NEW SUBNODE,DICT0,DICT1
NEW ACCNDX,ACCSTR,ACCNXT
;
S DICT0="90475.2"
;
I WOT["PHY" S SUBNODE=1
I WOT["LOC" S SUBNODE=2
S DICT1="90475.2"_SUBNODE
;
S ACCSTR=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
;
D ^XBFMK
K ERRS,FDA,IENS,DIE
S FDA(DICT0,"?+1,",.01)=ACCSTR ; Find the Accession node, or create it.
S FDA(DICT1,"+2,?+1,",.01)=OLD
S FDA(DICT1,"+2,?+1,",1)=NEW
S FDA(DICT1,"+2,?+1,",2)=$E($$NOW^XLFDT(),1,12)
S FDA(DICT1,"+2,?+1,",3)=$G(DUZ)
D UPDATE^DIE(,"FDA",,"ERRS")
I $D(ERRS("DIERR"))>0 D Q
. D BADSTUFF^BLRCHGER("SETINDX")
;
Q
;
; Change Location? -- Get location cloned and modified from ASK^LRWU
CHNGLOC ;
S OLN=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",13)
;
D ^XBFMK
S DIC("B")=OLN
S DIC("A")="PATIENT LOCATION:"
; S DIC=44
S DIC="^SC("
S DIC(0)="AMNEQ"
D ^DIC K DIC
I +Y<0 Q
;
S NLN=+Y
I OLN=NLN Q ; If "Old" = "New" don't bother, just quit
;
S NLNMN=$P($G(^SC(NLN,0)),"^",2) ; "New" Hospital Location Mnemonic
;
; Change the location in 4 Different files -- quit if LREND=1 (END Flag)
Q:$$SETLLAB ; (1) Lab Data File
Q:$$SETLACC ; (2) Accession File
Q:$$SETLORD ; (3) Order File
Q:$$SETLTXLG ; (4) IHS Lab Transaction Log (BLRTXLOG)
;
W !?5,"Location Change filed",!
;
; Create Audit entry
D SETINDX("LOC",LRAA,LRAD,LRAN,OLN,NLN)
;
Q
;
; Lab Data file.
SETLLAB() ;
NEW SUBFILE
S SUBFILE=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01)
D ^XBFMK
K ERRS,FDA,IENS
S IENS=LRIDT_","_LRDFN_","
I $G(LOCGET(LRSS,0))'="" D
. S FDA(SUBFILE,IENS,$G(LOCGET(LRSS,0)))=NLN_";SC("
I $G(LOCGET(LRSS,1))'="" D
. S FDA(SUBFILE,IENS,$G(LOCGET(LRSS,1)))=NLNMN
D FILE^DIE("K","FDA","ERRS")
;
I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("SETLLAB")
I $D(ERRS("DIERR"))<1 S LREND=0
;
;
Q LREND
;
; Accession file.
SETLACC() ;
D ^XBFMK
K DIE,ERRS,FDA,IENS
S IENS=LRAN_","_LRAD_","_LRAA_","
S FDA(68.02,IENS,$G(LOCGET("ACCESSION","ORDL")))=NLN
S FDA(68.02,IENS,$G(LOCGET("ACCESSION","RPTL")))=NLNMN
D FILE^DIE("K","FDA","ERRS")
;
I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("SETLACC")
I $D(ERRS("DIERR"))<1 S LREND=0
;
Q LREND
;
; Order file
SETLORD() ;
NEW DONE
;
S ON=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
S LRODT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4) ; Order Date
;
S (DONE,LRSN)=""
F S LRSN=$O(^LRO(69,"C",ON,LRODT,LRSN)) Q:LRSN=""!(DONE="D") D
. S LRTEST=0
. F S LRTEST=$O(^LRO(69,LRODT,1,LRSN,2,LRTEST)) Q:LRTEST=""!(LRTEST'?.N)!(DONE="D") D
.. S TSTSTR=(^LRO(69,LRODT,1,LRSN,2,LRTEST,0))
.. I $P(TSTSTR,"^",3)'=LRODT Q ; If Date doesn't match, skip
.. I $P(TSTSTR,"^",4)'=LRAA Q ; If Accession Area doesn't match, skip
.. I $P(TSTSTR,"^",5)'=LRAN Q ; If Accession Number doesn't match, skip
.. ;
.. ; Accession Matches -- Change Location
.. ;
.. S DONE="D" ; No matter what, quit after this
.. D ^XBFMK
.. K ERRS,FDA,IENS,DIE
.. S IENS=LRSN_","_LRODT_","
.. S FDA(69.01,IENS,$G(LOCGET("ORDER ENTRY","ORDL")))=NLN
.. S FDA(69.01,IENS,$G(LOCGET("ORDER ENTRY","RPTL")))=NLNMN
.. D FILE^DIE("K","FDA","ERRS")
.. ;
.. I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("SETLORD - 1")
.. ;
.. I $D(ERRS("DIERR"))<1 S LREND=0
;
Q LREND
;
; IHS Lab Transaction Log
SETLTXLG() ;
NEW BLRSN
S ON=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
S BLRSN=$O(^BLRTXLOG("C",ON,""))
I BLRSN="" D Q LREND
. D BADJUJU^BLRCHGER("SETLTXLG",$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),ON)
;
S DICT0="9009022"
;
D ^XBFMK
K ERRS,FDA,IENS,DIE
S IENS=BLRSN_","
S FDA(DICT0,IENS,1106)=NLN
D FILE^DIE("K","FDA","ERRS")
;
I $D(ERRS("DIERR"))>0 D
. W !!
. W "BLRSN:",BLRSN,!
. W " IENS:",IENS,!
. W " NPN:",NPN,!
. W " ON:",ON,!
. D BADSTUFF^BLRCHGER("SETLTXLG")
;
I $D(ERRS("DIERR"))<1 D
. S LREND=0
. S BLRLOGDA=BLRSN
;
Q LREND
;
PROVREPT ; EP - Provider Report
D ^XBFMK
S L="",DIC=90475.2,FLDS="[LAB PROV CHNG]",BY="[LAB PROV CHNG ACC SRT]",FR=""
S DHD="PROVIDER CHANGED AFTER ORDER FINALIZED"
D EN1^DIP
D BLRGPGR^BLRGMENU() ; Press Return
Q
;
LOCREPT ; EP - Location Report
D ^XBFMK
S L="",DIC=90475.2,FLDS="[LAB LOC CHNG]",BY="[LAB LOC CHNG ACC SRT]",FR=""
S DHD="LOCATION CHANGED AFTER ORDER FINALIZED"
D EN1^DIP
D BLRGPGR^BLRGMENU()
Q
;
BOTHREPT ; EP - Provider and/or Location Report (Combined)
D ^XBFMK
S L="",DIC=90475.2,FLDS="[LAB PROV LOC BOTH]",BY="ACCESSION",FR=""
S DHD="PROVIDER AND/OR LOCATION CHANGED AFTER ORDER FINALIZED"
D EN1^DIP
D BLRGPGR^BLRGMENU()
Q
BLRCHGPL ; IHS/OIT/MKK - CHANGE PROVIDER AND/OR LOCATION UTILITY ; 07/22/2005 8:05 AM ]
+1 ;;5.2;LR;**1020,1021,1022**;September 20, 2007
+2 ;;
+3 ; Some code cloned from SINGLE^LRWRKLST and then modified
MAIN ; EP
+1 ; Temp vars -- discard after routine completes
+2 NEW LRDFN,LRSS,LRAA,LRAD,LRAN,LRIDT,LRAAS
+3 NEW LRODT,LRSN,BLRLOGDA
+4 NEW LRACC,LREND,LRSTOP,LRTSE,LRUNC,LRURG
+5 NEW PROVSTR,LOCSTR,CCN,EDD
+6 NEW PROVGET,LOCGET
+7 NEW NPN,OPN,FDA,STR,ERRS
+8 NEW OLN,ON,NLN,NLNMN
+9 NEW ESIGNODE
+10 ;
+11 ; Node in the ^LR global where E-Sig data resides
SET ESIGNODE=9009027
+12 ;
+13 ; Setup array so that info can be gotten quickly
+14 DO PEP^BLRCHGPW
+15 ;
+16 ; Setup standard parameters
+17 DO URG^LRX
+18 ;
+19 ; Loop unil done
+20 FOR
Begin DoDot:1
+21 WRITE !!
+22 SET (LREND,LRUNC,LRSTOP,LRTSE,CCN)=0
+23 SET LRACC=""
+24 ; Get Lab Data from Accession number
DO ^LRWU4
+25 ; If nothing, then set END flag & Quit
IF LRAN<1
SET LREND=1
QUIT
+26 ;
+27 ; Make sure Accession exists
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:2
+28 WRITE !,"Doesn't exist."
+29 ; Press "Return" routine
DO BLRGPGR^BLRGMENU()
End DoDot:2
QUIT
+30 ;
+31 ; ----- BEGIN IHS/OIT/MKK MODIFICATION - Patch 1022
+32 ; If order came from OERR, don't allow change
+33 NEW LRSP
+34 ; Order Number
SET LRSN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
+35 ; Order Date
SET LRODT=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4)
+36 SET LRSP=+$ORDER(^LRO(69,"C",LRSN,LRODT,""))
+37 IF +$PIECE($GET(^LRO(69,LRODT,1,LRSP,0)),"^",11)>0
Begin DoDot:2
+38 WRITE !,"Accession is tied to an OERR order. This order cannot be modified.",!
+39 ; Press "Return" routine
DO BLRGPGR^BLRGMENU()
End DoDot:2
QUIT
+40 ; ----- END IHS/OIT/MKK -- MODIFICATION 1022
+41 ;
+42 ; Initialization
+43 KILL BLRLOGDA
+44 SET LRDFN=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",1)
+45 SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)
+46 ;
+47 ; Change Provider?
DO CHNGPROV
+48 ; Quit if END flag set
IF LREND
QUIT
+49 ; Change Location?
DO CHNGLOC
+50 ;
+51 ; If all OK, then send changes to PCC via BLR Linker
+52 ; I 'LREND&($D(BLRLOGDA)) D TOP^BLRQUE(BLRLOGDA,0)
+53 ; ----- BEGIN IHS/OIT/MKK -- MODIFICATION 1022
+54 ; All the BLRTXLOG transaction numbers are in the BLRLOGDA array --
+55 ; have to send over notice about all of them.
+56 IF 'LREND&($DATA(BLRLOGDA))
Begin DoDot:2
+57 SET BLRLOGDA=""
+58 FOR
SET BLRLOGDA=$ORDER(BLRLOGDA(BLRLOGDA))
IF BLRLOGDA=""
QUIT
Begin DoDot:3
+59 DO TOP^BLRQUE(BLRLOGDA,0)
End DoDot:3
End DoDot:2
+60 ; ----- END IHS/OIT/MKK -- MODIFICATION 1022
End DoDot:1
IF LREND!LRSTOP
QUIT
+61 ;
+62 QUIT
+63 ;
+64 ; Change Provider? -- Get provider cloned and modified from P^LRWU1
CHNGPROV ;
+1 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+2 ; Provider in Lab Data File -- default
SET OPN=$$GETPHY
+3 ;
+4 ; If Provider not in Lab Data File, get from Order Entry File
+5 IF OPN=""
Begin DoDot:1
+6 ; Order Number
SET ON=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
+7 ; Order Date
SET LRODT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4)
+8 ; Order Sequence Number
SET LRSN=$ORDER(^LRO(69,"C",ON,LRODT,""))
+9 ; Prov from Order Entry
SET OPN=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),"^",6)
End DoDot:1
+10 ;
+11 ; Clear Fileman Variables
DO ^XBFMK
+12 ; Default is current Provider
SET DIC("B")=OPN
+13 SET DIC="^VA(200,"
+14 SET DIC(0)="AMNEQ"
+15 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^BLRUTIL2(Y)"
+16 SET DIC("A")="PROVIDER: "
+17 SET D="AK.PROVIDER"
+18 SET DIC("W")="Q"
+19 DO ^DIC
KILL DIC
+20 ; If Quit or nothing, exit
IF Y<0
QUIT
+21 ;
+22 SET NPN=+Y
+23 ; If "Old" = "New" don't bother, just quit
IF OPN=NPN
QUIT
+24 ;
+25 ; Change the provider in 4 Different files -- quit if LREND=1 (END Flag)
+26 ; (1) Lab Data File
IF $$SETPLAB
QUIT
+27 ; (2) Accession File
IF $$SETPACC
QUIT
+28 ; (3) Order File
IF $$SETPORD
QUIT
+29 ; Q:$$SETPTXLG ; (4) IHS Lab Transaction Log (BLRTXLOG)
+30 ; ----- BEGIN IHS/OIT/MKK -- MODIFICATION 1022
+31 ; Took out code from BLRCHGPL and put into BLRCHGPW because
+32 ; BLRCHGPL got too large
+33 ; (4) IHS Lab Transaction Log (BLRTXLOG)
IF $$SETPTXLG^BLRCHGPW
QUIT
+34 ; ----- END IHS/OIT/MKK -- MODIFICATION 1022
+35 ;
+36 WRITE !?5,"Provider Change filed",!
+37 ;
+38 ; Create Audit entry
+39 DO SETINDX("PHY",LRAA,LRAD,LRAN,OPN,NPN)
+40 QUIT
+41 ;
GETPHY() ;
+1 ; Return Provider location in file
QUIT @$GET(PROVGET(LRSS))
+2 ;
+3 ; Change Provider in Lab Data file.
SETPLAB() ;
+1 NEW SUBFILE
+2 DO ^XBFMK
+3 KILL DIE,ERRS,FDA,IENS
+4 SET IENS=LRIDT_","_LRDFN_","
+5 SET SUBFILE=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01)
+6 SET FDA(SUBFILE,IENS,$GET(PROVGET(LRSS,0)))=NPN
+7 DO FILE^DIE("K","FDA","ERRS")
+8 ;
+9 IF $DATA(ERRS("DIERR"))>0
DO BADSTUFF^BLRCHGER("SETPLAB")
QUIT LREND
+10 IF $DATA(ERRS("DIERR"))<1
SET LREND=0
+11 ;
+12 ; D ESIGCHNG ; E-SIG Changes
+13 ; ----- BEGIN IHS/OIT/MKK -- MODIFICATION - 1022
+14 ; Moved the ESIGCHNG routine from BLRCHGPL to BLRCHGPW because
+15 ; BLRCHGPL was getting too large
+16 DO ESIGCHNG^BLRCHGPW
+17 ; ----- END IHS/OIT/MKK -- MODIFICATION - 1022
+18 ;
+19 QUIT LREND
+20 ;
+21 ; Change Provider in Accession file.
SETPACC() ;
+1 DO ^XBFMK
+2 KILL DIE,FDA,ERRS,IENS
+3 SET IENS=LRAN_","_LRAD_","_LRAA_","
+4 SET FDA(68.02,IENS,$GET(PROVGET("ACCESSION","PROV")))=NPN
+5 DO FILE^DIE("K","FDA","ERRS")
+6 ;
+7 IF $DATA(ERRS("DIERR"))>0
DO BADSTUFF^BLRCHGER("SETPACC")
QUIT LREND
+8 IF $DATA(ERRS("DIERR"))<1
SET LREND=0
+9 ;
+10 QUIT LREND
+11 ;
+12 ; Change Provider in Order Entry File
SETPORD() ;
+1 ; Order file
+2 NEW DONE
+3 ;
+4 ; Order Number
SET ON=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
+5 ; Order Date
SET LRODT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4)
+6 ;
+7 SET (DONE,LRSN)=""
+8 FOR
SET LRSN=$ORDER(^LRO(69,"C",ON,LRODT,LRSN))
IF LRSN=""!(DONE="D")
QUIT
Begin DoDot:1
+9 SET LRDFN=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),"^",1)
+10 SET LRTEST=0
+11 FOR
SET LRTEST=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTEST))
IF LRTEST=""!(LRTEST'?.N)!(DONE="D")
QUIT
Begin DoDot:2
+12 SET TSTSTR=(^LRO(69,LRODT,1,LRSN,2,LRTEST,0))
+13 ; If Date doesn't match, skip
IF $PIECE(TSTSTR,"^",3)'=LRODT
QUIT
+14 ; If Accession Area doesn't match, skip
IF $PIECE(TSTSTR,"^",4)'=LRAA
QUIT
+15 ; If Accession Number doesn't match, skip
IF $PIECE(TSTSTR,"^",5)'=LRAN
QUIT
+16 ;
+17 ; Accession Matches -- Change Provider
+18 ; No matter what, quit after this
SET DONE="D"
+19 DO ^XBFMK
+20 KILL DIE,FDA,ERRS,IENS
+21 SET IENS=LRSN_","_LRODT_","
+22 SET FDA(69.01,IENS,$GET(PROVGET("ORDER ENTRY")))=NPN
+23 DO FILE^DIE("K","FDA","ERRS")
+24 ;
+25 IF $DATA(ERRS("DIERR"))>0
DO BADSTUFF^BLRCHGER("SETPORD")
+26 IF $DATA(ERRS("DIERR"))<1
SET LREND=0
+27 ;
+28 ; Check to see if Provider REALLY changed
+29 IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),"^",6)'=NPN
Begin DoDot:3
+30 WRITE !!!,?5,$TRANSLATE($JUSTIFY("",45)," ","*"),!!
+31 WRITE ?5,$$CJ^XLFSTR("PROVIDER NOT CHANGED IN ORDER FILE",45),!!
+32 WRITE ?5,"Old Provider IEN:",OPN
+33 WRITE ?35,"New Prov IEN:",NPN
+34 WRITE ?5,$TRANSLATE($JUSTIFY("",45)," ","*"),!!
+35 SET LREND=1
End DoDot:3
QUIT
+36 ;
+37 ; Now, have to change X-Ref since FileMan isn't
+38 NEW PTPTR,PATNAME
+39 SET PTPTR=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+40 IF $GET(PTPTR)=""
QUIT
+41 ;
+42 ; Patient Name
SET PATNAME=$PIECE($GET(^DPT(PTPTR,0)),"^",1)
+43 IF $GET(PATNAME)=""
QUIT
+44 ;
+45 ; "Old" Provider Name"
NEW OPNAME
+46 SET OPNAME=$PIECE($GET(^VA(200,OPN,0)),"^",1)
+47 IF $DATA(^LRO(69,LRODT,1,"AP",OPNAME))<1
QUIT
+48 ;
+49 NEW IEN,OKNOW,TODT,TON
+50 SET (IEN,OKNOW)=""
+51 IF $DATA(^LRO(69,LRODT,1,"AP",OPNAME,PATNAME,ON))<1
QUIT
+52 ;
+53 NEW NPNAME
+54 SET NPNAME=$PIECE($GET(^VA(200,NPN,0)),"^",1)
+55 SET STR="^LRO(69,"_LRODT_",1,AP,"_OPNAME_","_PATNAME_","_ON_")"
+56 KILL @STR
+57 SET ^LRO(69,LRODT,1,"AP",NPNAME,PATNAME,ON)=""
End DoDot:2
End DoDot:1
+58 ;
+59 QUIT LREND
+60 ;
+61 ; Populate new global
SETINDX(WOT,LRAA,LRAD,LRAN,OLD,NEW) ;
+1 NEW SUBNODE,DICT0,DICT1
+2 NEW ACCNDX,ACCSTR,ACCNXT
+3 ;
+4 SET DICT0="90475.2"
+5 ;
+6 IF WOT["PHY"
SET SUBNODE=1
+7 IF WOT["LOC"
SET SUBNODE=2
+8 SET DICT1="90475.2"_SUBNODE
+9 ;
+10 SET ACCSTR=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+11 ;
+12 DO ^XBFMK
+13 KILL ERRS,FDA,IENS,DIE
+14 ; Find the Accession node, or create it.
SET FDA(DICT0,"?+1,",.01)=ACCSTR
+15 SET FDA(DICT1,"+2,?+1,",.01)=OLD
+16 SET FDA(DICT1,"+2,?+1,",1)=NEW
+17 SET FDA(DICT1,"+2,?+1,",2)=$EXTRACT($$NOW^XLFDT(),1,12)
+18 SET FDA(DICT1,"+2,?+1,",3)=$GET(DUZ)
+19 DO UPDATE^DIE(,"FDA",,"ERRS")
+20 IF $DATA(ERRS("DIERR"))>0
Begin DoDot:1
+21 DO BADSTUFF^BLRCHGER("SETINDX")
End DoDot:1
QUIT
+22 ;
+23 QUIT
+24 ;
+25 ; Change Location? -- Get location cloned and modified from ASK^LRWU
CHNGLOC ;
+1 SET OLN=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",13)
+2 ;
+3 DO ^XBFMK
+4 SET DIC("B")=OLN
+5 SET DIC("A")="PATIENT LOCATION:"
+6 ; S DIC=44
+7 SET DIC="^SC("
+8 SET DIC(0)="AMNEQ"
+9 DO ^DIC
KILL DIC
+10 IF +Y<0
QUIT
+11 ;
+12 SET NLN=+Y
+13 ; If "Old" = "New" don't bother, just quit
IF OLN=NLN
QUIT
+14 ;
+15 ; "New" Hospital Location Mnemonic
SET NLNMN=$PIECE($GET(^SC(NLN,0)),"^",2)
+16 ;
+17 ; Change the location in 4 Different files -- quit if LREND=1 (END Flag)
+18 ; (1) Lab Data File
IF $$SETLLAB
QUIT
+19 ; (2) Accession File
IF $$SETLACC
QUIT
+20 ; (3) Order File
IF $$SETLORD
QUIT
+21 ; (4) IHS Lab Transaction Log (BLRTXLOG)
IF $$SETLTXLG
QUIT
+22 ;
+23 WRITE !?5,"Location Change filed",!
+24 ;
+25 ; Create Audit entry
+26 DO SETINDX("LOC",LRAA,LRAD,LRAN,OLN,NLN)
+27 ;
+28 QUIT
+29 ;
+30 ; Lab Data file.
SETLLAB() ;
+1 NEW SUBFILE
+2 SET SUBFILE=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="BB":63.01)
+3 DO ^XBFMK
+4 KILL ERRS,FDA,IENS
+5 SET IENS=LRIDT_","_LRDFN_","
+6 IF $GET(LOCGET(LRSS,0))'=""
Begin DoDot:1
+7 SET FDA(SUBFILE,IENS,$GET(LOCGET(LRSS,0)))=NLN_";SC("
End DoDot:1
+8 IF $GET(LOCGET(LRSS,1))'=""
Begin DoDot:1
+9 SET FDA(SUBFILE,IENS,$GET(LOCGET(LRSS,1)))=NLNMN
End DoDot:1
+10 DO FILE^DIE("K","FDA","ERRS")
+11 ;
+12 IF $DATA(ERRS("DIERR"))>0
DO BADSTUFF^BLRCHGER("SETLLAB")
+13 IF $DATA(ERRS("DIERR"))<1
SET LREND=0
+14 ;
+15 ;
+16 QUIT LREND
+17 ;
+18 ; Accession file.
SETLACC() ;
+1 DO ^XBFMK
+2 KILL DIE,ERRS,FDA,IENS
+3 SET IENS=LRAN_","_LRAD_","_LRAA_","
+4 SET FDA(68.02,IENS,$GET(LOCGET("ACCESSION","ORDL")))=NLN
+5 SET FDA(68.02,IENS,$GET(LOCGET("ACCESSION","RPTL")))=NLNMN
+6 DO FILE^DIE("K","FDA","ERRS")
+7 ;
+8 IF $DATA(ERRS("DIERR"))>0
DO BADSTUFF^BLRCHGER("SETLACC")
+9 IF $DATA(ERRS("DIERR"))<1
SET LREND=0
+10 ;
+11 QUIT LREND
+12 ;
+13 ; Order file
SETLORD() ;
+1 NEW DONE
+2 ;
+3 ; Order Number
SET ON=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
+4 ; Order Date
SET LRODT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",4)
+5 ;
+6 SET (DONE,LRSN)=""
+7 FOR
SET LRSN=$ORDER(^LRO(69,"C",ON,LRODT,LRSN))
IF LRSN=""!(DONE="D")
QUIT
Begin DoDot:1
+8 SET LRTEST=0
+9 FOR
SET LRTEST=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTEST))
IF LRTEST=""!(LRTEST'?.N)!(DONE="D")
QUIT
Begin DoDot:2
+10 SET TSTSTR=(^LRO(69,LRODT,1,LRSN,2,LRTEST,0))
+11 ; If Date doesn't match, skip
IF $PIECE(TSTSTR,"^",3)'=LRODT
QUIT
+12 ; If Accession Area doesn't match, skip
IF $PIECE(TSTSTR,"^",4)'=LRAA
QUIT
+13 ; If Accession Number doesn't match, skip
IF $PIECE(TSTSTR,"^",5)'=LRAN
QUIT
+14 ;
+15 ; Accession Matches -- Change Location
+16 ;
+17 ; No matter what, quit after this
SET DONE="D"
+18 DO ^XBFMK
+19 KILL ERRS,FDA,IENS,DIE
+20 SET IENS=LRSN_","_LRODT_","
+21 SET FDA(69.01,IENS,$GET(LOCGET("ORDER ENTRY","ORDL")))=NLN
+22 SET FDA(69.01,IENS,$GET(LOCGET("ORDER ENTRY","RPTL")))=NLNMN
+23 DO FILE^DIE("K","FDA","ERRS")
+24 ;
+25 IF $DATA(ERRS("DIERR"))>0
DO BADSTUFF^BLRCHGER("SETLORD - 1")
+26 ;
+27 IF $DATA(ERRS("DIERR"))<1
SET LREND=0
End DoDot:2
End DoDot:1
+28 ;
+29 QUIT LREND
+30 ;
+31 ; IHS Lab Transaction Log
SETLTXLG() ;
+1 NEW BLRSN
+2 ; Order Number
SET ON=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
+3 SET BLRSN=$ORDER(^BLRTXLOG("C",ON,""))
+4 IF BLRSN=""
Begin DoDot:1
+5 DO BADJUJU^BLRCHGER("SETLTXLG",$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),ON)
End DoDot:1
QUIT LREND
+6 ;
+7 SET DICT0="9009022"
+8 ;
+9 DO ^XBFMK
+10 KILL ERRS,FDA,IENS,DIE
+11 SET IENS=BLRSN_","
+12 SET FDA(DICT0,IENS,1106)=NLN
+13 DO FILE^DIE("K","FDA","ERRS")
+14 ;
+15 IF $DATA(ERRS("DIERR"))>0
Begin DoDot:1
+16 WRITE !!
+17 WRITE "BLRSN:",BLRSN,!
+18 WRITE " IENS:",IENS,!
+19 WRITE " NPN:",NPN,!
+20 WRITE " ON:",ON,!
+21 DO BADSTUFF^BLRCHGER("SETLTXLG")
End DoDot:1
+22 ;
+23 IF $DATA(ERRS("DIERR"))<1
Begin DoDot:1
+24 SET LREND=0
+25 SET BLRLOGDA=BLRSN
End DoDot:1
+26 ;
+27 QUIT LREND
+28 ;
PROVREPT ; EP - Provider Report
+1 DO ^XBFMK
+2 SET L=""
SET DIC=90475.2
SET FLDS="[LAB PROV CHNG]"
SET BY="[LAB PROV CHNG ACC SRT]"
SET FR=""
+3 SET DHD="PROVIDER CHANGED AFTER ORDER FINALIZED"
+4 DO EN1^DIP
+5 ; Press Return
DO BLRGPGR^BLRGMENU()
+6 QUIT
+7 ;
LOCREPT ; EP - Location Report
+1 DO ^XBFMK
+2 SET L=""
SET DIC=90475.2
SET FLDS="[LAB LOC CHNG]"
SET BY="[LAB LOC CHNG ACC SRT]"
SET FR=""
+3 SET DHD="LOCATION CHANGED AFTER ORDER FINALIZED"
+4 DO EN1^DIP
+5 DO BLRGPGR^BLRGMENU()
+6 QUIT
+7 ;
BOTHREPT ; EP - Provider and/or Location Report (Combined)
+1 DO ^XBFMK
+2 SET L=""
SET DIC=90475.2
SET FLDS="[LAB PROV LOC BOTH]"
SET BY="ACCESSION"
SET FR=""
+3 SET DHD="PROVIDER AND/OR LOCATION CHANGED AFTER ORDER FINALIZED"
+4 DO EN1^DIP
+5 DO BLRGPGR^BLRGMENU()
+6 QUIT
