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

BLRCHGPW.m

Go to the documentation of this file.
  1. 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
  1. ;;
  1. ; Information as to where the provider or location are stored
  1. PEP ; EP
  1. ; Provider information
  1. S PROVGET("ACCESSION","PROV")=6.5
  1. S PROVGET("ORDER ENTRY")=7
  1. S PROVGET("AU")="$P($G(^LR(LRDFN,LRSS)),""^"",7)" ; Autopsy
  1. S PROVGET("AU",0)=13.5
  1. S PROVGET("BB")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)" ; Blood Bank
  1. S PROVGET("BB",0)=.07
  1. S PROVGET("CH")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",10)" ; Chemistry
  1. S PROVGET("CH",0)=.1
  1. S PROVGET("CY")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)" ; Cytology
  1. S PROVGET("CY",0)=.07
  1. S PROVGET("MI")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)" ; Microbiology
  1. S PROVGET("MI",0)=.07
  1. S PROVGET("SP")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",7)" ; Surgical Pathology
  1. S PROVGET("SP",0)=.07
  1. ;
  1. ; Location information
  1. S LOCGET("ACCESSION","ORDL")=94 ; Accession File
  1. S LOCGET("ACCESSION","RPTL")=6
  1. S LOCGET("ORDER ENTRY","ORDL")=23 ; Order Entry File
  1. S LOCGET("ORDER ENTRY","RPTL")=8
  1. ;
  1. S LOCGET("AU")="$P($G(^LR(LRDFN,LRSS)),""^"",5)" ; Autopsy
  1. S LOCGET("AU",0)=14.1
  1. S LOCGET("BB")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)" ; Blood Bank
  1. S LOCGET("BB",0)=.08
  1. S LOCGET("CH")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",10)" ; Chemistry
  1. S LOCGET("CH",0)=.111
  1. S LOCGET("CH",1)=.11
  1. S LOCGET("CY")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)" ; Cytology
  1. S LOCGET("CY",0)=.08
  1. S LOCGET("MI")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)" ; Microbiology
  1. S LOCGET("MI",0)=.08
  1. S LOCGET("SP")="$P($G(^LR(LRDFN,LRSS,LRIDT,0)),""^"",8)" ; Surgical Pathology
  1. S LOCGET("SP",0)=.08
  1. ;
  1. Q
  1. ;
  1. ; Change Provider in IHS Lab Transaction Log
  1. ; Orignally this code was in the BLRCHGPL routine, but taken out and put
  1. ; here because the BLRCHGPL routine became too large.
  1. SETPTXLG() ; EP
  1. NEW BLRSN,DICT0
  1. S ON=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
  1. ;
  1. ; ----- BEGIN IHS/OIT/MKK -- MODIFICATION - 1022
  1. ; Need to modify ALL the transactions, not
  1. ; just the first one found. This means a
  1. ; total rewrite of the code.
  1. ;
  1. ; S BLRSN=$O(^BLRTXLOG("C",ON,""))
  1. ; I BLRSN="" D Q LREND
  1. ; . D BADJUJU("SETPTXLG",$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),ON)
  1. ;
  1. ; S DICT0="9009022"
  1. ;
  1. ; D ^XBFMK
  1. ; K ERRS,FDA,IENS,DIE
  1. ; S IENS=BLRSN_","
  1. ; S FDA(DICT0,IENS,1104)=NPN
  1. ; D FILE^DIE("K","FDA","ERRS")
  1. ; I $D(ERRS("DIERR"))<1 D
  1. ; . S LREND=0
  1. ; . S BLRLOGDA=BLRSN ; IHS Lab Transaction Sequence Number
  1. ;
  1. ; I $D(ERRS("DIERR"))>0 D
  1. ; . W !!
  1. ; . W "BLRSN:",BLRSN,!
  1. ; . W " IENS:",IENS,!
  1. ; . W " NPN:",NPN,!
  1. ; . W " ON:",ON,!
  1. ; . D BADSTUFF("SETPTXLG")
  1. ;
  1. ; ----- IHS/OIT/MKK -- REWRITE begins here
  1. NEW CNT,QFLG
  1. ;
  1. S DICT0="9009022"
  1. S BLRSN="",CNT=0
  1. F S BLRSN=$O(^BLRTXLOG("C",ON,BLRSN)) Q:BLRSN=""!(LREND=1) D
  1. . D ^XBFMK
  1. . K ERRS,FDA,IENS,DIE
  1. . S IENS=BLRSN_","
  1. . S FDA(DICT0,IENS,1104)=NPN
  1. . D FILE^DIE("K","FDA","ERRS")
  1. . ;
  1. . I $D(ERRS("DIERR"))<1 D
  1. .. S LREND=0
  1. .. S BLRLOGDA(BLRSN)="" ; IHS Lab Transaction Log Sequence Number
  1. .. S CNT=CNT+1
  1. . ;
  1. . I $D(ERRS("DIERR"))>0 D
  1. .. W !!
  1. .. W "BLRSN:",BLRSN,!
  1. .. W " IENS:",IENS,!
  1. .. W " NPN:",NPN,!
  1. .. W " ON:",ON,!
  1. .. D BADSTUFF^BLRCHGER("SETPTXLG")
  1. ;
  1. I CNT<1 D Q LREND
  1. . D BADJUJU^BLRCHGER("SETPTXLG",$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),ON)
  1. ; ----- END IHS/OIT/MKK -- MODIFICATION - 1022
  1. ;
  1. Q LREND
  1. ;
  1. ;
  1. ; ----- BEGIN IHS/OIT/MKK -- MODIFICATION - 1022
  1. ; Moved the following routine from BLRCHGPL because the BLRCHGPL routine
  1. ; was becoming too large.
  1. ;
  1. ; Delete "Old" Provider from E-SIG entry and add "New" Provider
  1. ; in E-SIG. If possible.
  1. ESIGCHNG ; EP
  1. ; If no E-SIG data for the accession, quit
  1. I $G(^LR(LRDFN,LRSS,LRIDT,ESIGNODE))="" Q
  1. ;
  1. ; If not CH nor MI, quit -- BB doesn't have E-SIG
  1. I $G(LRSS)="BB" Q
  1. ;
  1. NEW OESIG,NESIG,MID,IMNOTE,SUBFILE
  1. S SUBFILE=$S(LRSS="CH":63.04,LRSS="MI":63.05)
  1. ;
  1. ; Setup NOTE string -- may be needed
  1. S MID=(IOM\2)-10
  1. S IMNOTE=$TR($J("",IOM)," ","*")
  1. S $E(IMNOTE,MID,MID+15)=" IMPORTANT NOTE "
  1. ;
  1. ; If Review Status is NOT 0, give message & quit
  1. I $P($G(^LR(LRDFN,LRSS,LRIDT,ESIGNODE)),"^",1)>0 D Q
  1. . W !!,IMNOTE,!!
  1. . W $$CJ^XLFSTR("Accession's E-SIG Status is not Zero.",IOM),!
  1. . W $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
  1. . W IMNOTE,!!
  1. . D BLRGPGR^BLRGMENU()
  1. ;
  1. S NESIG=$P($G(^VA(200,NPN,20)),"^",4) ; "New" Provider E-SIG value
  1. ;
  1. I $G(NESIG)="" D Q
  1. . W !!,IMNOTE,!!
  1. . W $$CJ^XLFSTR("'New' Provider "_$E($P($G(^VA(200,NPN,0)),"^",1),1,18),IOM)
  1. . W $$CJ^XLFSTR("IS NOT an E-SIG participant",IOM),!
  1. . W $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
  1. . W IMNOTE,!!
  1. . D BLRGPGR^BLRGMENU()
  1. ;
  1. S OESIG=$P($G(^VA(200,OPN,20)),"^",4) ; "Old" Provider E-SIG value
  1. ;
  1. I $G(OESIG)="" D Q
  1. . W !!,IMNOTE,!!
  1. . W $$CJ^XLFSTR("'Original' Provider "_$E($P($G(^VA(200,OPN,0)),"^",1),1,18),IOM)
  1. . W $$CJ^XLFSTR("IS NOT an E-SIG participant",IOM),!
  1. . W $$CJ^XLFSTR("No Change to E-SIG file.",IOM),!!
  1. . W IMNOTE,!!
  1. . D BLRGPGR^BLRGMENU()
  1. ;
  1. ; Both are E-SIG participants. Valid to change.
  1. ;
  1. ; Change Responsible Physician
  1. D ^XBFMK
  1. K DIE,ERRS,FDA,IENS
  1. S IENS=LRIDT_","_LRDFN_","
  1. S FDA(SUBFILE,IENS,.9009026)=NPN
  1. D FILE^DIE("K","FDA","ERRS")
  1. I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("ESIGCHNG - Responsible Phy") Q LREND
  1. ;
  1. ; Change Review Status
  1. D ^XBFMK
  1. K DIE,ERRS,FDA,IENS
  1. S IENS=LRIDT_","_LRDFN_","
  1. S FDA(SUBFILE,IENS,.9009025)=0
  1. D FILE^DIE("K","FDA","ERRS")
  1. ;
  1. I $D(ERRS("DIERR"))>0 D BADSTUFF^BLRCHGER("ESIGCHNG - Review Status") Q LREND
  1. ;
  1. ; Make sure INDEX is also reset
  1. NEW ILRIDT
  1. S ILRIDT=-LRIDT
  1. M ^LR("BLRA",NPN,0,ILRIDT)=^LR("BLRA",OPN,0,ILRIDT)
  1. K ^LR("BLRA",OPN,0,ILRIDT)
  1. ;
  1. Q
  1. ; ----- END IHS/OIT/MKK -- MODIFICATION - 1022