- 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