BLRCHGPW ; IHS/OIT/MKK - CHANGE PROVIDER AND/OR LOCATION UTILITY -- Part 2; 08/30/2005 8:05 AM ]
;;5.2;LR;**1020,1022**;September 20, 2007
;;
; Information as to where the provider or location are stored
PEP ; EP
; Provider information
S PROVGET("ACCESSION","PROV")=6.5
S PROVGET("ORDER ENTRY")=7
S PROVGET("AU")="$P($G(^LR(LRDFN,LRSS)),""^"",7)" ; Autopsy
S PROVGET("AU",0)=13.5
S PROVGET("BB")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)" ; Blood Bank
S PROVGET("BB",0)=.07
S PROVGET("CH")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",10)" ; Chemistry
S PROVGET("CH",0)=.1
S PROVGET("CY")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)" ; Cytology
S PROVGET("CY",0)=.07
S PROVGET("MI")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)" ; Microbiology
S PROVGET("MI",0)=.07
S PROVGET("SP")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)" ; Surgical Pathology
S PROVGET("SP",0)=.07
;
; Location information
S LOCGET("ACCESSION","ORDL")=94 ; Accession File
S LOCGET("ACCESSION","RPTL")=6
S LOCGET("ORDER ENTRY","ORDL")=23 ; Order Entry File
S LOCGET("ORDER ENTRY","RPTL")=8
;
S LOCGET("AU")="$P($G(^LR(LRDFN,LRSS)),""^"",5)" ; Autopsy
S LOCGET("AU",0)=14.1
S LOCGET("BB")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)" ; Blood Bank
S LOCGET("BB",0)=.08
S LOCGET("CH")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",10)" ; Chemistry
S LOCGET("CH",0)=.111
S LOCGET("CH",1)=.11
S LOCGET("CY")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)" ; Cytology
S LOCGET("CY",0)=.08
S LOCGET("MI")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)" ; Microbiology
S LOCGET("MI",0)=.08
S LOCGET("SP")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)" ; Surgical Pathology
S LOCGET("SP",0)=.08
;
Q
;
; Change Provider in IHS Lab Transaction Log
; Orignally this code was in the BLRCHGPL routine, but taken out and put
; here because the BLRCHGPL routine became too large.
SETPTXLG() ; EP
NEW BLRSN,DICT0
S ON=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
;
; ----- BEGIN IHS/OIT/MKK -- MODIFICATION - 1022
; Need to modify ALL the transactions, not
; just the first one found. This means a
; total rewrite of the code.
;
; S BLRSN=$O(^BLRTXLOG("C",ON,""))
; I BLRSN="" D Q LREND
; . D BADJUJU("SETPTXLG",$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,1104)=NPN
; D FILE^DIE("K","FDA","ERRS")
; I $D(ERRS("DIERR"))<1 D
; . S LREND=0
; . S BLRLOGDA=BLRSN ; IHS Lab Transaction Sequence Number
;
; I $D(ERRS("DIERR"))>0 D
; . W !!
; . W "BLRSN:",BLRSN,!
; . W " IENS:",IENS,!
; . W " NPN:",NPN,!
; . W " ON:",ON,!
; . D BADSTUFF("SETPTXLG")
;
; ----- IHS/OIT/MKK -- REWRITE begins here
NEW CNT,QFLG
;
S DICT0="9009022"
S BLRSN="",CNT=0
F S BLRSN=$O(^BLRTXLOG("C",ON,BLRSN)) Q:BLRSN=""!(LREND=1) D
. D ^XBFMK
. K ERRS,FDA,IENS,DIE
. S IENS=BLRSN_","
. S FDA(DICT0,IENS,1104)=NPN
. D FILE^DIE("K","FDA","ERRS")
. ;
. I $D(ERRS("DIERR"))<1 D
.. S LREND=0
.. S BLRLOGDA(BLRSN)="" ; IHS Lab Transaction Log Sequence Number
.. S CNT=CNT+1
. ;
. I $D(ERRS("DIERR"))>0 D
.. W !!
.. W "BLRSN:",BLRSN,!
.. W " IENS:",IENS,!
.. W " NPN:",NPN,!
.. W " ON:",ON,!
.. D BADSTUFF^BLRCHGER("SETPTXLG")
;
I CNT<1 D Q LREND
. D BADJUJU^BLRCHGER("SETPTXLG",$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),ON)
; ----- END IHS/OIT/MKK -- MODIFICATION - 1022
;
Q LREND
;
;
; ----- BEGIN IHS/OIT/MKK -- MODIFICATION - 1022
; Moved the following routine from BLRCHGPL because the BLRCHGPL routine
; was becoming too large.
;
; Delete "Old" Provider from E-SIG entry and add "New" Provider
; in E-SIG. If possible.
ESIGCHNG ; EP
; If no E-SIG data for the accession, quit
I $G(^LR(LRDFN,LRSS,LRIDT,ESIGNODE))="" Q
;
; If not CH nor MI, quit -- BB doesn't have E-SIG
I $G(LRSS)="BB" Q
;
NEW OESIG,NESIG,MID,IMNOTE,SUBFILE
S SUBFILE=$S(LRSS="CH":63.04,LRSS="MI":63.05)
;
; Setup NOTE string -- may be needed
S MID=(IOM\2)-10
S IMNOTE=$TR($J("",IOM)," ","*")
S $E(IMNOTE,MID,MID+15)=" IMPORTANT NOTE "
;
; If Review Status is NOT 0, give message & quit
I $P($G(^LR(LRDFN,LRSS,LRIDT,ESIGNODE)),"^",1)>0 D Q
. W !!,IMNOTE,!!
. W $$CJ^XLFSTR("Accession's E-SIG Status is not Zero.",IOM),!
. W $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
. W IMNOTE,!!
. D BLRGPGR^BLRGMENU()
;
S NESIG=$P($G(^VA(200,NPN,20)),"^",4) ; "New" Provider E-SIG value
;
I $G(NESIG)="" D Q
. W !!,IMNOTE,!!
. W $$CJ^XLFSTR("'New' Provider "_$E($P($G(^VA(200,NPN,0)),"^",1),1,18),IOM)
. W $$CJ^XLFSTR("IS NOT an E-SIG participant",IOM),!
. W $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
. W IMNOTE,!!
. D BLRGPGR^BLRGMENU()
;
S OESIG=$P($G(^VA(200,OPN,20)),"^",4) ; "Old" Provider E-SIG value
;
I $G(OESIG)="" D Q
. W !!,IMNOTE,!!
. W $$CJ^XLFSTR("'Original' Provider "_$E($P($G(^VA(200,OPN,0)),"^",1),1,18),IOM)
. W $$CJ^XLFSTR("IS NOT an E-SIG participant",IOM),!
. W $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
. W IMNOTE,!!
. D BLRGPGR^BLRGMENU()
;
; Both are E-SIG participants. Valid to change.
;
; Change Responsible Physician
D ^XBFMK
K DIE,ERRS,FDA,IENS
S IENS=LRIDT_","_LRDFN_","
S FDA(SUBFILE,IENS,.9009026)=NPN
D FILE^DIE("K","FDA","ERRS")
I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("ESIGCHNG - Responsible Phy") Q LREND
;
; Change Review Status
D ^XBFMK
K DIE,ERRS,FDA,IENS
S IENS=LRIDT_","_LRDFN_","
S FDA(SUBFILE,IENS,.9009025)=0
D FILE^DIE("K","FDA","ERRS")
;
I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("ESIGCHNG - Review Status") Q LREND
;
; Make sure INDEX is also reset
NEW ILRIDT
S ILRIDT=-LRIDT
M ^LR("BLRA",NPN,0,ILRIDT)=^LR("BLRA",OPN,0,ILRIDT)
K ^LR("BLRA",OPN,0,ILRIDT)
;
Q
; ----- END IHS/OIT/MKK -- MODIFICATION - 1022
BLRCHGPW ; IHS/OIT/MKK - CHANGE PROVIDER AND/OR LOCATION UTILITY -- Part 2; 08/30/2005 8:05 AM ]
+1 ;;5.2;LR;**1020,1022**;September 20, 2007
+2 ;;
+3 ; Information as to where the provider or location are stored
PEP ; EP
+1 ; Provider information
+2 SET PROVGET("ACCESSION","PROV")=6.5
+3 SET PROVGET("ORDER ENTRY")=7
+4 ; Autopsy
SET PROVGET("AU")="$P($G(^LR(LRDFN,LRSS)),""^"",7)"
+5 SET PROVGET("AU",0)=13.5
+6 ; Blood Bank
SET PROVGET("BB")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)"
+7 SET PROVGET("BB",0)=.07
+8 ; Chemistry
SET PROVGET("CH")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",10)"
+9 SET PROVGET("CH",0)=.1
+10 ; Cytology
SET PROVGET("CY")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)"
+11 SET PROVGET("CY",0)=.07
+12 ; Microbiology
SET PROVGET("MI")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)"
+13 SET PROVGET("MI",0)=.07
+14 ; Surgical Pathology
SET PROVGET("SP")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)"
+15 SET PROVGET("SP",0)=.07
+16 ;
+17 ; Location information
+18 ; Accession File
SET LOCGET("ACCESSION","ORDL")=94
+19 SET LOCGET("ACCESSION","RPTL")=6
+20 ; Order Entry File
SET LOCGET("ORDER ENTRY","ORDL")=23
+21 SET LOCGET("ORDER ENTRY","RPTL")=8
+22 ;
+23 ; Autopsy
SET LOCGET("AU")="$P($G(^LR(LRDFN,LRSS)),""^"",5)"
+24 SET LOCGET("AU",0)=14.1
+25 ; Blood Bank
SET LOCGET("BB")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)"
+26 SET LOCGET("BB",0)=.08
+27 ; Chemistry
SET LOCGET("CH")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",10)"
+28 SET LOCGET("CH",0)=.111
+29 SET LOCGET("CH",1)=.11
+30 ; Cytology
SET LOCGET("CY")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)"
+31 SET LOCGET("CY",0)=.08
+32 ; Microbiology
SET LOCGET("MI")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)"
+33 SET LOCGET("MI",0)=.08
+34 ; Surgical Pathology
SET LOCGET("SP")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)"
+35 SET LOCGET("SP",0)=.08
+36 ;
+37 QUIT
+38 ;
+39 ; Change Provider in IHS Lab Transaction Log
+40 ; Orignally this code was in the BLRCHGPL routine, but taken out and put
+41 ; here because the BLRCHGPL routine became too large.
SETPTXLG() ; EP
+1 NEW BLRSN,DICT0
+2 ; Order Number
SET ON=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
+3 ;
+4 ; ----- BEGIN IHS/OIT/MKK -- MODIFICATION - 1022
+5 ; Need to modify ALL the transactions, not
+6 ; just the first one found. This means a
+7 ; total rewrite of the code.
+8 ;
+9 ; S BLRSN=$O(^BLRTXLOG("C",ON,""))
+10 ; I BLRSN="" D Q LREND
+11 ; . D BADJUJU("SETPTXLG",$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),ON)
+12 ;
+13 ; S DICT0="9009022"
+14 ;
+15 ; D ^XBFMK
+16 ; K ERRS,FDA,IENS,DIE
+17 ; S IENS=BLRSN_","
+18 ; S FDA(DICT0,IENS,1104)=NPN
+19 ; D FILE^DIE("K","FDA","ERRS")
+20 ; I $D(ERRS("DIERR"))<1 D
+21 ; . S LREND=0
+22 ; . S BLRLOGDA=BLRSN ; IHS Lab Transaction Sequence Number
+23 ;
+24 ; I $D(ERRS("DIERR"))>0 D
+25 ; . W !!
+26 ; . W "BLRSN:",BLRSN,!
+27 ; . W " IENS:",IENS,!
+28 ; . W " NPN:",NPN,!
+29 ; . W " ON:",ON,!
+30 ; . D BADSTUFF("SETPTXLG")
+31 ;
+32 ; ----- IHS/OIT/MKK -- REWRITE begins here
+33 NEW CNT,QFLG
+34 ;
+35 SET DICT0="9009022"
+36 SET BLRSN=""
SET CNT=0
+37 FOR
SET BLRSN=$ORDER(^BLRTXLOG("C",ON,BLRSN))
IF BLRSN=""!(LREND=1)
QUIT
Begin DoDot:1
+38 DO ^XBFMK
+39 KILL ERRS,FDA,IENS,DIE
+40 SET IENS=BLRSN_","
+41 SET FDA(DICT0,IENS,1104)=NPN
+42 DO FILE^DIE("K","FDA","ERRS")
+43 ;
+44 IF $DATA(ERRS("DIERR"))<1
Begin DoDot:2
+45 SET LREND=0
+46 ; IHS Lab Transaction Log Sequence Number
SET BLRLOGDA(BLRSN)=""
+47 SET CNT=CNT+1
End DoDot:2
+48 ;
+49 IF $DATA(ERRS("DIERR"))>0
Begin DoDot:2
+50 WRITE !!
+51 WRITE "BLRSN:",BLRSN,!
+52 WRITE " IENS:",IENS,!
+53 WRITE " NPN:",NPN,!
+54 WRITE " ON:",ON,!
+55 DO BADSTUFF^BLRCHGER("SETPTXLG")
End DoDot:2
End DoDot:1
+56 ;
+57 IF CNT<1
Begin DoDot:1
+58 DO BADJUJU^BLRCHGER("SETPTXLG",$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),ON)
End DoDot:1
QUIT LREND
+59 ; ----- END IHS/OIT/MKK -- MODIFICATION - 1022
+60 ;
+61 QUIT LREND
+62 ;
+63 ;
+64 ; ----- BEGIN IHS/OIT/MKK -- MODIFICATION - 1022
+65 ; Moved the following routine from BLRCHGPL because the BLRCHGPL routine
+66 ; was becoming too large.
+67 ;
+68 ; Delete "Old" Provider from E-SIG entry and add "New" Provider
+69 ; in E-SIG. If possible.
ESIGCHNG ; EP
+1 ; If no E-SIG data for the accession, quit
+2 IF $GET(^LR(LRDFN,LRSS,LRIDT,ESIGNODE))=""
QUIT
+3 ;
+4 ; If not CH nor MI, quit -- BB doesn't have E-SIG
+5 IF $GET(LRSS)="BB"
QUIT
+6 ;
+7 NEW OESIG,NESIG,MID,IMNOTE,SUBFILE
+8 SET SUBFILE=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05)
+9 ;
+10 ; Setup NOTE string -- may be needed
+11 SET MID=(IOM\2)-10
+12 SET IMNOTE=$TRANSLATE($JUSTIFY("",IOM)," ","*")
+13 SET $EXTRACT(IMNOTE,MID,MID+15)=" IMPORTANT NOTE "
+14 ;
+15 ; If Review Status is NOT 0, give message & quit
+16 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,ESIGNODE)),"^",1)>0
Begin DoDot:1
+17 WRITE !!,IMNOTE,!!
+18 WRITE $$CJ^XLFSTR("Accession's E-SIG Status is not Zero.",IOM),!
+19 WRITE $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
+20 WRITE IMNOTE,!!
+21 DO BLRGPGR^BLRGMENU()
End DoDot:1
QUIT
+22 ;
+23 ; "New" Provider E-SIG value
SET NESIG=$PIECE($GET(^VA(200,NPN,20)),"^",4)
+24 ;
+25 IF $GET(NESIG)=""
Begin DoDot:1
+26 WRITE !!,IMNOTE,!!
+27 WRITE $$CJ^XLFSTR("'New' Provider "_$EXTRACT($PIECE($GET(^VA(200,NPN,0)),"^",1),1,18),IOM)
+28 WRITE $$CJ^XLFSTR("IS NOT an E-SIG participant",IOM),!
+29 WRITE $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
+30 WRITE IMNOTE,!!
+31 DO BLRGPGR^BLRGMENU()
End DoDot:1
QUIT
+32 ;
+33 ; "Old" Provider E-SIG value
SET OESIG=$PIECE($GET(^VA(200,OPN,20)),"^",4)
+34 ;
+35 IF $GET(OESIG)=""
Begin DoDot:1
+36 WRITE !!,IMNOTE,!!
+37 WRITE $$CJ^XLFSTR("'Original' Provider "_$EXTRACT($PIECE($GET(^VA(200,OPN,0)),"^",1),1,18),IOM)
+38 WRITE $$CJ^XLFSTR("IS NOT an E-SIG participant",IOM),!
+39 WRITE $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
+40 WRITE IMNOTE,!!
+41 DO BLRGPGR^BLRGMENU()
End DoDot:1
QUIT
+42 ;
+43 ; Both are E-SIG participants. Valid to change.
+44 ;
+45 ; Change Responsible Physician
+46 DO ^XBFMK
+47 KILL DIE,ERRS,FDA,IENS
+48 SET IENS=LRIDT_","_LRDFN_","
+49 SET FDA(SUBFILE,IENS,.9009026)=NPN
+50 DO FILE^DIE("K","FDA","ERRS")
+51 IF $DATA(ERRS("DIERR"))>0
DO BADSTUFF^BLRCHGER("ESIGCHNG - Responsible Phy")
QUIT LREND
+52 ;
+53 ; Change Review Status
+54 DO ^XBFMK
+55 KILL DIE,ERRS,FDA,IENS
+56 SET IENS=LRIDT_","_LRDFN_","
+57 SET FDA(SUBFILE,IENS,.9009025)=0
+58 DO FILE^DIE("K","FDA","ERRS")
+59 ;
+60 IF $DATA(ERRS("DIERR"))>0
DO BADSTUFF^BLRCHGER("ESIGCHNG - Review Status")
QUIT LREND
+61 ;
+62 ; Make sure INDEX is also reset
+63 NEW ILRIDT
+64 SET ILRIDT=-LRIDT
+65 MERGE ^LR("BLRA",NPN,0,ILRIDT)=^LR("BLRA",OPN,0,ILRIDT)
+66 KILL ^LR("BLRA",OPN,0,ILRIDT)
+67 ;
+68 QUIT
+69 ; ----- END IHS/OIT/MKK -- MODIFICATION - 1022
