BLRUTIL4 ;IHS/MSC/MKK - MISC IHS LAB UTILITIES (Cont) ; 17-Jul-2015 06:30 ; MKK
;;5.2;LR;**1031,1033,1034,1035**;NOV 01, 1997;Build 5
;
; Determines if MODULE exists on server
MODEXIST(MODULE) ; EP
NEW HEREYAGO,NAME,PATCH,PTR,SYSVER,VERSION
;
D FIND^DIC(9.4,"",,,MODULE,,"C",,,"HEREYAGO")
S PTR=+$G(HEREYAGO("DILIST",2,1))
;
Q:PTR<1 "0^NOT ON THIS SERVER^"
;
; Special logic for INTEGRATED BILLING
I $G(HEREYAGO("DILIST",1,1))["INTEGRATED BILL" Q "0^NOT ON THIS SERVER^"
I $G(HEREYAGO("DILIST",1,1))["IB ENCOUNTER" Q "0^NOT ON THIS SERVER^"
;
S SYSVER=+$$VERSION^XPDUTL(MODULE) ; Get Current Version #
;
; Special logic for VA Clinical Reminders
Q:MODULE="PXRM"&(SYSVER<2) "0^NOT ON THIS SERVER^"
;
; Special logic for VA Patient Encounter module
I MODULE="PCE"!(MODULE="PX") D
. Q:MODULE="PXRM" ; Skip Clinical Reminders
. S MODULE="PX"
. S VERSION="1.0"
. S PATCH=168 ; Latest VA Patch as of 5/1/2009
. S PATCH=197 ; IHS/MSC/MKK - LR*5.2*1033 - Latest VA Patch as of 2011
. S PATCH=203 ; IHS/MSC/MKK - LR*5.2*1034 - Seq 152, June 2014
. S SYSPATCH=$$PATCH^XPDUTL(MODULE_"*"_VERSION_"*"_PATCH)
. S:SYSPATCH<1 SYSVER=0
;
; If PTR>0 but SYSVER<1, then Module is a stub.
; Full Module (with all of its routines) does not exist on the server.
Q:SYSVER<1 "0^NOT ON THIS SERVER^"
;
S NAME=$G(HEREYAGO("DILIST",1,1))
;
Q PTR_"^"_NAME_"^"_SYSVER
;
; Get Health Record Number -- see LA7UID2 routine
GETHRCN(LRDFN,INHRCN) ; EP
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
; Check to make sure the HRCN is the correct one for the Ordering Location
I +$G(INHRCN) D
. NEW DFN,IENS,ORDHRCN,ORDLOC,OLINST
. S IENS=LA76802_","_LA76801_","_LA768_","
. S ORDLOC=+$$GET1^DIQ(68.02,IENS,94,"I")
. S OLINST=+$$GET1^DIQ(44,ORDLOC,3,"I")
. Q:OLINST<1
. ;
. S DFN=+$P($G(^LR(LRDFN,0)),"^",3)
. S ORDHRCN=+$$HRN^AUPNPAT(DFN,OLINST)
. Q:ORDHRCN<1
. ;
. S:ORDHRCN'=INHRCN INHRCN=ORDHRCN
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
Q:+$G(INHRCN) +$G(INHRCN) ; If #, just return it
;
; If LRDFN not from VA Patient file, return passed variable.
I $P($G(^LR(LRDFN,0)),"^",2)'=2 Q $G(INHRCN)
;
; New variables
NEW ACCINST,DFN,HRCN,LRIDT,LRSS
;
; Get Patient file IEN
S DFN=+$P($G(^LR(LRDFN,0)),"^",3)
;
; Use IHS DICTIONARIES function call
S HRCN=$$HRN^AUPNPAT(DFN,DUZ(2))
;
Q:+HRCN HRCN
;
; DUZ(2) did not return the HRCN.
; Use the Lab Data File's ACCESSIONING INSTITUTION field.
;
; Get Lab Data File Subscript
S LRSS=$P($G(^LRO(68,+$G(LRAA),0)),"^",2)
;
; If LRSS still null, try LA7UID accession variable
S:LRSS="" LRSS=$P($G(^LRO(68,+$G(LA768),0)),"^",2)
;
; Could not retrieve Subscript, so return passed variable.
Q:$L(LRSS)<1 $G(INHRCN)
;
; Try to get LRIDT using LRAA,LRAD,LRAN variables
S LRIDT=$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),3)),"^",5)
;
; If LRIDT still null, try LA7UID accession variables
S:LRIDT="" LRIDT=$P($G(^LRO(68,+$G(LA768),1,+$G(LA76801),1,+$G(LA76802),3)),"^",5)
;
; If LRIDT still null, return passed variable.
Q:$L(LRIDT)<1 $G(INHRCN)
;
; Get ACCessioning INSTitution
S ACCINST=+$P($G(^LR(LRDFN,LRSS,+$G(LRIDT),0)),"^",14)
;
S HRCN=$$HRN^AUPNPAT(DFN,ACCINST)
;
Q:+HRCN HRCN
;
D ENTRYAUD^BLRUTIL("GETHRCN^BLRUTIL4 8.5")
;
; Could not retrieve HRCN, so return passed variable.
Q $G(INHRCN)
;
; Generic "Find RPMS Module's Version and (perhaps) Patch number"
; The MODULE variable MUST be the PREFIX name from the PACKAGE file (9.4).
NEEDIT(MODULE,VERSION,PATCH) ; EP
NEW NAME ; Name of PACKAGE
NEW HEREYAGO,STR1,STR2 ; Scratch variables/arrays
NEW SYSVER,SYSPATCH ; System Version & System Patch variables
;
D FIND^DIC(9.4,"","","",MODULE,"","C","","","HEREYAGO")
S NAME=$G(HEREYAGO("DILIST",1,1))
;
S SYSVER=$$VERSION^XPDUTL(MODULE) ; Get the System's Version
;
; If System Version < Needed Version, write message and quit
I SYSVER<VERSION D Q
. W !,?4,"Need "_NAME_" "_VERSION_" & "_NAME_" "_SYSVER_" found!",!!
;
D OKAY^BLRKIDSU(NAME_" "_SYSVER_" found.")
I VERSION<SYSVER Q ; If Version needed is lower, skip Patch check
;
I $G(PATCH)="" Q ; If no Patch check, just exit
;
D BMES^XPDUTL(" Need "_NAME_" "_VERSION_" Patch "_PATCH)
S SYSPATCH=$$PATCH(MODULE_"*"_VERSION_"*"_PATCH)
I SYSPATCH'=1 D Q
. S ERRARRAY(MODULE,NAME,VERSION)=$G(PATCH)
. D MES^XPDUTL($J("",10)_" & Patch "_PATCH_" WAS NOT installed!")
;
D OKAY^BLRKIDSU("& Patch "_PATCH_" found.",10)
;
Q
;
PACKSTR(X) ; EP - Remove Extra Spaces from within string
F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,9999)
Q X
;
; Code cloned from PATCH^XPDUTL
PATCH(X) ;EP - Return 1 if patch X was installed, X=aaaa*nn.nn*nnn
Q:X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.6N 0
N %,I,J
S I=$O(^DIC(9.4,"C",$P(X,"*"),0)) Q:'I 0
S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0
;check if patch is just a number
;
Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1
;
S %=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
Q (X=+%)
;
CURLABP() ; EP - Return current Lab Patch
NEW LABPATCH,PTR,STATUS,WOTPATCH
;
S LABPATCH="<UNK>",STATUS=0,WOTPATCH="LR*5.2*1099"
F S WOTPATCH=$O(^XPD(9.7,"B",WOTPATCH),-1) Q:WOTPATCH=""!($E(WOTPATCH,1,2)'="LR")!(STATUS=3) D
. S PTR="AAA"
. F S PTR=$O(^XPD(9.7,"B",WOTPATCH,PTR),-1) Q:PTR=""!(STATUS=3) D
.. S STATUS=$P($G(^XPD(9.7,PTR,0)),"^",9)
.. S:STATUS=3 LABPATCH=WOTPATCH
;
Q LABPATCH
;
; The following moved from LRRP1 because LRRP1 became > 15000 bytes
; The following moved from LRRP1 because LRRP1 became > 15000 bytes
GETCOMPD() ; EP -- Get Completion Date for test
NEW COMPD,D3,DATALN,LRAA,LRAD,LRAN,LRAS,LRAT,LRSS,LOG,STR,TESTIEN,TMPDT,VLABIEN
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 0.0") ; IHS/MSC/MKK - LR*5.2*1034
;
S LRAS=$P(LR0,"^",6)
Q:'$L(LRAS) " "
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 1.0") ; IHS/MSC/MKK - LR*5.2*1034
;
; If no Pointer to file 60, return null
S TESTIEN=+$P($G(LRDATA),"^",1)
Q:TESTIEN<1 " "
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 2.0") ; IHS/MSC/MKK - LR*5.2*1034
;
; If test PENDING, there is no complete date -- return null
S DATALN=+$P($P($G(^LAB(60,+$G(LRTSTS),0)),"^",5),";",2)
I $$UP^XLFSTR($P($G(^LR(LRDFN,"CH",LRIDT,DATALN)),"^",1))["PEND" Q " "
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
; Try to get COMPLETE DATE from Lab Data File
; S COMPD=+$G(^LR(LRDFN,"CH",LRIDT,+$P(LRDATA,U,10),"IHS"))
S COMPD=$G(^LR(LRDFN,"CH",LRIDT,+$P(LRDATA,U,10),"IHS")) ; IHS/MSC/MKK - LR*5.2*1035
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 3.0") ; IHS/MSC/MKK - LR*5.2*1035
;
I +COMPD,COMPD["," S COMPD=$$HTFM^XLFDT(COMPD) ; IHS/MSC/MKK - LR*5.2*1035
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 3.5") ; IHS/MSC/MKK - LR*5.2*1035
;
Q:+$G(COMPD)>2000000 $$FMTE^XLFDT(COMPD,"2MZ")
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
; Break out Accession variables
I $$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)<1 Q " "
;
; If Accession Date (LRAD) year not the same as the collection date year, set LRAD = 0
I $E(LRAD,1,3)'=$E($P($G(LRCDT),"."),1,3) S LRAD=0
;
; Try to get COMPLETE DATE for the test from Accession file
S COMPD=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TESTIEN,0)),"^",5)
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 4.0") ; IHS/MSC/MKK - LR*5.2*1035
;
Q:+$G(COMPD)>2000000 $$FMTE^XLFDT(COMPD,"2MZ")
;
; Completed date is null in Accession file; will try to get date
; from the BLRTXLOG file
S (COMPD,VLABIEN,LOG)=0
F S LOG=$O(^BLRTXLOG("D",LRAS,LOG)) Q:LOG<1!(COMPD>0) D
. I $P($G(^BLRTXLOG(LOG,1)),"^",2)'="R" Q ; Not RESULTED
. I $P($G(^BLRTXLOG(LOG,0)),"^",6)'=TESTIEN Q ; Wrong test
. I $E(LRAD,1,3)'=$E($P($P($G(^BLRTXLOG(LOG,12)),"^"),"."),1,3) Q ; Wrong year
. ;
. S COMPD=+$P($G(^BLRTXLOG(LOG,13)),"^",9)
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 5.0") ; IHS/MSC/MKK - LR*5.2*1034
;
Q:+$G(COMPD)>2000000 $$FMTE^XLFDT(COMPD,"2MZ")
;
; Still null. Try to find the test in the V LAB file and use test's
; Accession #, IEN, and Collection Date to match
;
S VLABIEN=.9999999
F S VLABIEN=$O(^AUPNVLAB("ALR0",LRAS,VLABIEN)) Q:VLABIEN<1!(COMPD>0) D
. I $P($G(^AUPNVLAB(VLABIEN,0)),"^")'=TESTIEN Q ; If TEST doesn't match, skip
. ; Collection Date/Time match only down to minutes, not seconds
. I $E($P($G(^AUPNVLAB(VLABIEN,12)),"^",1),1,12)'=$E($P(LR0,"^"),1,12) Q
. ;
. S COMPD=+$P($G(^AUPNVLAB(VLABIEN,12)),"^",12) ; V LAB Result Date
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 6.0") ; IHS/MSC/MKK - LR*5.2*1034
;
Q:+$G(COMPD)>2000000 $$FMTE^XLFDT(COMPD,"2MZ")
;
; If still null, try the Lab Data File's DATE REPORT COMPLETED Date
; that's stored in the LR0 variable
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
; Don't use DATE REPORT COMPLETED because it's NOT at the test level.
; S COMPD=$P(LR0,"^",3)
; ----- END IHS/MSC/MKK - LR*5.2*1034
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
; The Lab Data File's DATE REPORT COMPLETED Date must be used
; otherwise tests on a panel will never have a completed date.
S COMPD=$P(LR0,"^",3)
; ----- END IHS/MSC/MKK - LR*5.2*1035
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 7.0") ; IHS/MSC/MKK - LR*5.2*1034
;
Q:+$G(COMPD)>2000000 $$FMTE^XLFDT(COMPD,"2MZ")
;
D ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 8.0") ; IHS/MSC/MKK - LR*5.2*1035
;
; All results dates checked and nothing found, so quit with null
Q " "
;
;
ENTRYAUD(LABEL,TMPNODE) ; EP - Audit ^TMP global
NEW ENTRYNUM,NOW,NOWTIM
;
S NOW=$$NOW^XLFDT
S ENTRYNUM=$G(^BLRENTRY)+1
S $P(^BLRENTRY,U)=ENTRYNUM
M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL_" ^TMP")=^TMP(TMPNODE)
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
; Given an UID, return the LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT variables
RETACCV(UID,LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT,LRAS) ; EP
S (LRAA,LRAD,LRAN,LRAS,LRDFN,LRSS,LRIDT)="" ; Initialize all the variables
;
S X=$Q(^LRO(68,"C",UID,0))
Q:$L(X)<1 ; Skip if no accession data
;
S LRAA=+$QS(X,4),LRAD=+$QS(X,5),LRAN=+$QS(X,6)
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
S LRSS=$$GET1^DIQ(68,LRAA,.09,"I")
S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
;
S LRAS=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,"ACCESSION")
Q
;
SETUCUM ; EP - Set value into IHS UCUM dictionary
NEW FDA,IEN,UCUM,UDESC,UPRNITN
;
W !!
;
S UCUM=$$GETSTRNG("UCUM Definitiion")
Q:UCUM="Q"
;
S UDESC=$$GETSTRNG("UCUM Description")
Q:UDESC="Q"
;
S UPRINTN=$$GETSTRNG("UCUM Print Name")
Q:UPRINTN="Q"
;
S FDA(90475.3,"+1,",.01)=UCUM
S FDA(90475.3,"+1,",1)=UDESC
S FDA(90475.3,"+1,",3)=UPRINTN
;
D UPDATE^DIE("S","FDA",,"ERRS")
;
I $D(ERRS) D Q
. W !,?4,"Error adding UCUM. Error Message Follows:"
. D ARRYDUMP("ERRS")
. D PRESSKEY^BLRGMENU(9)
;
S IEN=$$FIND1^DIC(90475.3,,,UCUM)
K FDA,ERRS
S FDA(90475.32,"+1,"_IEN_",",.01)=UPRINTN
D UPDATE^DIE("S","FDA",,"ERRS")
;
I $D(ERRS) D Q
. W !,?4,"Error adding ",UPRINTN," as a SYNONYM. Error Message Follows:"
. D ARRYDUMP("ERRS")
. D PRESSKEY^BLRGMENU(9)
;
W !!,?4,"Succesfully added UCUM at IEN:",IEN,!
D PRESSKEY^BLRGMENU(9)
;
Q
;
GETSTRNG(STR) ; EP
D ^XBFMK
S DIR(0)="FO"
S DIR("A")=STR
D ^DIR
I $G(X)=""!(+$G(DIRUT)) D Q "Q"
. W !!,?4,"No/Invalid/Quit Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
Q $G(X)
;
; "Dump" an array
ARRYDUMP(ARRY) ; EP
NEW COL,MESSAGE,STR1,TOOWIDE,WIDTH
;
S STR1=$Q(@ARRY@(""))
S MESSAGE=@STR1
;
W !,?5,ARRY,!
W ?10,STR1,"="
S COL=$X
D ARRYDMP2(COL,MESSAGE)
;
F S STR1=$Q(@STR1) Q:STR1="" D
. S MESSAGE=@STR1
. W ?10,STR1,"="
. S COL=$X
. D ARRYDMP2(COL,MESSAGE)
Q
;
ARRYDMP2(COL,MESSAGE) ; EP - Output string. If too wide, wrap it.
S WIDTH=(IOM-COL-1)
S TOOWIDE=$S((COL+$L(MESSAGE))<IOM:0,1:1)
;
I 'TOOWIDE W MESSAGE,! Q
;
I TOOWIDE D LINEWRAP^BLRGMENU(COL,MESSAGE,WIDTH) W !
Q
;
NOPCEINS ; EP - NO PCE INStalled notice
W !,?4,"VA Patient Encounter module does NOT exist on this sytem."
D PRESSKEY^BLRGMENU
Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
BLRUTIL4 ;IHS/MSC/MKK - MISC IHS LAB UTILITIES (Cont) ; 17-Jul-2015 06:30 ; MKK
+1 ;;5.2;LR;**1031,1033,1034,1035**;NOV 01, 1997;Build 5
+2 ;
+3 ; Determines if MODULE exists on server
MODEXIST(MODULE) ; EP
+1 NEW HEREYAGO,NAME,PATCH,PTR,SYSVER,VERSION
+2 ;
+3 DO FIND^DIC(9.4,"",,,MODULE,,"C",,,"HEREYAGO")
+4 SET PTR=+$GET(HEREYAGO("DILIST",2,1))
+5 ;
+6 IF PTR<1
QUIT "0^NOT ON THIS SERVER^"
+7 ;
+8 ; Special logic for INTEGRATED BILLING
+9 IF $GET(HEREYAGO("DILIST",1,1))["INTEGRATED BILL"
QUIT "0^NOT ON THIS SERVER^"
+10 IF $GET(HEREYAGO("DILIST",1,1))["IB ENCOUNTER"
QUIT "0^NOT ON THIS SERVER^"
+11 ;
+12 ; Get Current Version #
SET SYSVER=+$$VERSION^XPDUTL(MODULE)
+13 ;
+14 ; Special logic for VA Clinical Reminders
+15 IF MODULE="PXRM"&(SYSVER<2)
QUIT "0^NOT ON THIS SERVER^"
+16 ;
+17 ; Special logic for VA Patient Encounter module
+18 IF MODULE="PCE"!(MODULE="PX")
Begin DoDot:1
+19 ; Skip Clinical Reminders
IF MODULE="PXRM"
QUIT
+20 SET MODULE="PX"
+21 SET VERSION="1.0"
+22 ; Latest VA Patch as of 5/1/2009
SET PATCH=168
+23 ; IHS/MSC/MKK - LR*5.2*1033 - Latest VA Patch as of 2011
SET PATCH=197
+24 ; IHS/MSC/MKK - LR*5.2*1034 - Seq 152, June 2014
SET PATCH=203
+25 SET SYSPATCH=$$PATCH^XPDUTL(MODULE_"*"_VERSION_"*"_PATCH)
+26 IF SYSPATCH<1
SET SYSVER=0
End DoDot:1
+27 ;
+28 ; If PTR>0 but SYSVER<1, then Module is a stub.
+29 ; Full Module (with all of its routines) does not exist on the server.
+30 IF SYSVER<1
QUIT "0^NOT ON THIS SERVER^"
+31 ;
+32 SET NAME=$GET(HEREYAGO("DILIST",1,1))
+33 ;
+34 QUIT PTR_"^"_NAME_"^"_SYSVER
+35 ;
+36 ; Get Health Record Number -- see LA7UID2 routine
GETHRCN(LRDFN,INHRCN) ; EP
+1 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+2 ; Check to make sure the HRCN is the correct one for the Ordering Location
+3 IF +$GET(INHRCN)
Begin DoDot:1
+4 NEW DFN,IENS,ORDHRCN,ORDLOC,OLINST
+5 SET IENS=LA76802_","_LA76801_","_LA768_","
+6 SET ORDLOC=+$$GET1^DIQ(68.02,IENS,94,"I")
+7 SET OLINST=+$$GET1^DIQ(44,ORDLOC,3,"I")
+8 IF OLINST<1
QUIT
+9 ;
+10 SET DFN=+$PIECE($GET(^LR(LRDFN,0)),"^",3)
+11 SET ORDHRCN=+$$HRN^AUPNPAT(DFN,OLINST)
+12 IF ORDHRCN<1
QUIT
+13 ;
+14 IF ORDHRCN'=INHRCN
SET INHRCN=ORDHRCN
End DoDot:1
+15 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+16 ;
+17 ; If #, just return it
IF +$GET(INHRCN)
QUIT +$GET(INHRCN)
+18 ;
+19 ; If LRDFN not from VA Patient file, return passed variable.
+20 IF $PIECE($GET(^LR(LRDFN,0)),"^",2)'=2
QUIT $GET(INHRCN)
+21 ;
+22 ; New variables
+23 NEW ACCINST,DFN,HRCN,LRIDT,LRSS
+24 ;
+25 ; Get Patient file IEN
+26 SET DFN=+$PIECE($GET(^LR(LRDFN,0)),"^",3)
+27 ;
+28 ; Use IHS DICTIONARIES function call
+29 SET HRCN=$$HRN^AUPNPAT(DFN,DUZ(2))
+30 ;
+31 IF +HRCN
QUIT HRCN
+32 ;
+33 ; DUZ(2) did not return the HRCN.
+34 ; Use the Lab Data File's ACCESSIONING INSTITUTION field.
+35 ;
+36 ; Get Lab Data File Subscript
+37 SET LRSS=$PIECE($GET(^LRO(68,+$GET(LRAA),0)),"^",2)
+38 ;
+39 ; If LRSS still null, try LA7UID accession variable
+40 IF LRSS=""
SET LRSS=$PIECE($GET(^LRO(68,+$GET(LA768),0)),"^",2)
+41 ;
+42 ; Could not retrieve Subscript, so return passed variable.
+43 IF $LENGTH(LRSS)<1
QUIT $GET(INHRCN)
+44 ;
+45 ; Try to get LRIDT using LRAA,LRAD,LRAN variables
+46 SET LRIDT=$PIECE($GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),3)),"^",5)
+47 ;
+48 ; If LRIDT still null, try LA7UID accession variables
+49 IF LRIDT=""
SET LRIDT=$PIECE($GET(^LRO(68,+$GET(LA768),1,+$GET(LA76801),1,+$GET(LA76802),3)),"^",5)
+50 ;
+51 ; If LRIDT still null, return passed variable.
+52 IF $LENGTH(LRIDT)<1
QUIT $GET(INHRCN)
+53 ;
+54 ; Get ACCessioning INSTitution
+55 SET ACCINST=+$PIECE($GET(^LR(LRDFN,LRSS,+$GET(LRIDT),0)),"^",14)
+56 ;
+57 SET HRCN=$$HRN^AUPNPAT(DFN,ACCINST)
+58 ;
+59 IF +HRCN
QUIT HRCN
+60 ;
+61 DO ENTRYAUD^BLRUTIL("GETHRCN^BLRUTIL4 8.5")
+62 ;
+63 ; Could not retrieve HRCN, so return passed variable.
+64 QUIT $GET(INHRCN)
+65 ;
+66 ; Generic "Find RPMS Module's Version and (perhaps) Patch number"
+67 ; The MODULE variable MUST be the PREFIX name from the PACKAGE file (9.4).
NEEDIT(MODULE,VERSION,PATCH) ; EP
+1 ; Name of PACKAGE
NEW NAME
+2 ; Scratch variables/arrays
NEW HEREYAGO,STR1,STR2
+3 ; System Version & System Patch variables
NEW SYSVER,SYSPATCH
+4 ;
+5 DO FIND^DIC(9.4,"","","",MODULE,"","C","","","HEREYAGO")
+6 SET NAME=$GET(HEREYAGO("DILIST",1,1))
+7 ;
+8 ; Get the System's Version
SET SYSVER=$$VERSION^XPDUTL(MODULE)
+9 ;
+10 ; If System Version < Needed Version, write message and quit
+11 IF SYSVER<VERSION
Begin DoDot:1
+12 WRITE !,?4,"Need "_NAME_" "_VERSION_" & "_NAME_" "_SYSVER_" found!",!!
End DoDot:1
QUIT
+13 ;
+14 DO OKAY^BLRKIDSU(NAME_" "_SYSVER_" found.")
+15 ; If Version needed is lower, skip Patch check
IF VERSION<SYSVER
QUIT
+16 ;
+17 ; If no Patch check, just exit
IF $GET(PATCH)=""
QUIT
+18 ;
+19 DO BMES^XPDUTL(" Need "_NAME_" "_VERSION_" Patch "_PATCH)
+20 SET SYSPATCH=$$PATCH(MODULE_"*"_VERSION_"*"_PATCH)
+21 IF SYSPATCH'=1
Begin DoDot:1
+22 SET ERRARRAY(MODULE,NAME,VERSION)=$GET(PATCH)
+23 DO MES^XPDUTL($JUSTIFY("",10)_" & Patch "_PATCH_" WAS NOT installed!")
End DoDot:1
QUIT
+24 ;
+25 DO OKAY^BLRKIDSU("& Patch "_PATCH_" found.",10)
+26 ;
+27 QUIT
+28 ;
PACKSTR(X) ; EP - Remove Extra Spaces from within string
+1 FOR
IF X'[" "
QUIT
SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,9999)
+2 QUIT X
+3 ;
+4 ; Code cloned from PATCH^XPDUTL
PATCH(X) ;EP - Return 1 if patch X was installed, X=aaaa*nn.nn*nnn
+1 IF X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.6N
QUIT 0
+2 NEW %,I,J
+3 SET I=$ORDER(^DIC(9.4,"C",$PIECE(X,"*"),0))
IF 'I
QUIT 0
+4 SET J=$ORDER(^DIC(9.4,I,22,"B",$PIECE(X,"*",2),0))
SET X=$PIECE(X,"*",3)
IF 'J
QUIT 0
+5 ;check if patch is just a number
+6 ;
+7 IF $ORDER(^DIC(9.4,I,22,J,"PAH","B",X,0))
QUIT 1
+8 ;
+9 SET %=$ORDER(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))
+10 QUIT (X=+%)
+11 ;
CURLABP() ; EP - Return current Lab Patch
+1 NEW LABPATCH,PTR,STATUS,WOTPATCH
+2 ;
+3 SET LABPATCH="<UNK>"
SET STATUS=0
SET WOTPATCH="LR*5.2*1099"
+4 FOR
SET WOTPATCH=$ORDER(^XPD(9.7,"B",WOTPATCH),-1)
IF WOTPATCH=""!($EXTRACT(WOTPATCH,1,2)'="LR")!(STATUS=3)
QUIT
Begin DoDot:1
+5 SET PTR="AAA"
+6 FOR
SET PTR=$ORDER(^XPD(9.7,"B",WOTPATCH,PTR),-1)
IF PTR=""!(STATUS=3)
QUIT
Begin DoDot:2
+7 SET STATUS=$PIECE($GET(^XPD(9.7,PTR,0)),"^",9)
+8 IF STATUS=3
SET LABPATCH=WOTPATCH
End DoDot:2
End DoDot:1
+9 ;
+10 QUIT LABPATCH
+11 ;
+12 ; The following moved from LRRP1 because LRRP1 became > 15000 bytes
+13 ; The following moved from LRRP1 because LRRP1 became > 15000 bytes
GETCOMPD() ; EP -- Get Completion Date for test
+1 NEW COMPD,D3,DATALN,LRAA,LRAD,LRAN,LRAS,LRAT,LRSS,LOG,STR,TESTIEN,TMPDT,VLABIEN
+2 ;
+3 ; IHS/MSC/MKK - LR*5.2*1034
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 0.0")
+4 ;
+5 SET LRAS=$PIECE(LR0,"^",6)
+6 IF '$LENGTH(LRAS)
QUIT " "
+7 ;
+8 ; IHS/MSC/MKK - LR*5.2*1034
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 1.0")
+9 ;
+10 ; If no Pointer to file 60, return null
+11 SET TESTIEN=+$PIECE($GET(LRDATA),"^",1)
+12 IF TESTIEN<1
QUIT " "
+13 ;
+14 ; IHS/MSC/MKK - LR*5.2*1034
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 2.0")
+15 ;
+16 ; If test PENDING, there is no complete date -- return null
+17 SET DATALN=+$PIECE($PIECE($GET(^LAB(60,+$GET(LRTSTS),0)),"^",5),";",2)
+18 IF $$UP^XLFSTR($PIECE($GET(^LR(LRDFN,"CH",LRIDT,DATALN)),"^",1))["PEND"
QUIT " "
+19 ;
+20 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+21 ; Try to get COMPLETE DATE from Lab Data File
+22 ; S COMPD=+$G(^LR(LRDFN,"CH",LRIDT,+$P(LRDATA,U,10),"IHS"))
+23 ; IHS/MSC/MKK - LR*5.2*1035
SET COMPD=$GET(^LR(LRDFN,"CH",LRIDT,+$PIECE(LRDATA,U,10),"IHS"))
+24 ;
+25 ; IHS/MSC/MKK - LR*5.2*1035
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 3.0")
+26 ;
+27 ; IHS/MSC/MKK - LR*5.2*1035
IF +COMPD
IF COMPD[","
SET COMPD=$$HTFM^XLFDT(COMPD)
+28 ;
+29 ; IHS/MSC/MKK - LR*5.2*1035
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 3.5")
+30 ;
+31 IF +$GET(COMPD)>2000000
QUIT $$FMTE^XLFDT(COMPD,"2MZ")
+32 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+33 ;
+34 ; Break out Accession variables
+35 IF $$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)<1
QUIT " "
+36 ;
+37 ; If Accession Date (LRAD) year not the same as the collection date year, set LRAD = 0
+38 IF $EXTRACT(LRAD,1,3)'=$EXTRACT($PIECE($GET(LRCDT),"."),1,3)
SET LRAD=0
+39 ;
+40 ; Try to get COMPLETE DATE for the test from Accession file
+41 SET COMPD=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TESTIEN,0)),"^",5)
+42 ;
+43 ; IHS/MSC/MKK - LR*5.2*1035
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 4.0")
+44 ;
+45 IF +$GET(COMPD)>2000000
QUIT $$FMTE^XLFDT(COMPD,"2MZ")
+46 ;
+47 ; Completed date is null in Accession file; will try to get date
+48 ; from the BLRTXLOG file
+49 SET (COMPD,VLABIEN,LOG)=0
+50 FOR
SET LOG=$ORDER(^BLRTXLOG("D",LRAS,LOG))
IF LOG<1!(COMPD>0)
QUIT
Begin DoDot:1
+51 ; Not RESULTED
IF $PIECE($GET(^BLRTXLOG(LOG,1)),"^",2)'="R"
QUIT
+52 ; Wrong test
IF $PIECE($GET(^BLRTXLOG(LOG,0)),"^",6)'=TESTIEN
QUIT
+53 ; Wrong year
IF $EXTRACT(LRAD,1,3)'=$EXTRACT($PIECE($PIECE($GET(^BLRTXLOG(LOG,12)),"^"),"."),1,3)
QUIT
+54 ;
+55 SET COMPD=+$PIECE($GET(^BLRTXLOG(LOG,13)),"^",9)
End DoDot:1
+56 ;
+57 ; IHS/MSC/MKK - LR*5.2*1034
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 5.0")
+58 ;
+59 IF +$GET(COMPD)>2000000
QUIT $$FMTE^XLFDT(COMPD,"2MZ")
+60 ;
+61 ; Still null. Try to find the test in the V LAB file and use test's
+62 ; Accession #, IEN, and Collection Date to match
+63 ;
+64 SET VLABIEN=.9999999
+65 FOR
SET VLABIEN=$ORDER(^AUPNVLAB("ALR0",LRAS,VLABIEN))
IF VLABIEN<1!(COMPD>0)
QUIT
Begin DoDot:1
+66 ; If TEST doesn't match, skip
IF $PIECE($GET(^AUPNVLAB(VLABIEN,0)),"^")'=TESTIEN
QUIT
+67 ; Collection Date/Time match only down to minutes, not seconds
+68 IF $EXTRACT($PIECE($GET(^AUPNVLAB(VLABIEN,12)),"^",1),1,12)'=$EXTRACT($PIECE(LR0,"^"),1,12)
QUIT
+69 ;
+70 ; V LAB Result Date
SET COMPD=+$PIECE($GET(^AUPNVLAB(VLABIEN,12)),"^",12)
End DoDot:1
+71 ;
+72 ; IHS/MSC/MKK - LR*5.2*1034
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 6.0")
+73 ;
+74 IF +$GET(COMPD)>2000000
QUIT $$FMTE^XLFDT(COMPD,"2MZ")
+75 ;
+76 ; If still null, try the Lab Data File's DATE REPORT COMPLETED Date
+77 ; that's stored in the LR0 variable
+78 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+79 ; Don't use DATE REPORT COMPLETED because it's NOT at the test level.
+80 ; S COMPD=$P(LR0,"^",3)
+81 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+82 ;
+83 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+84 ; The Lab Data File's DATE REPORT COMPLETED Date must be used
+85 ; otherwise tests on a panel will never have a completed date.
+86 SET COMPD=$PIECE(LR0,"^",3)
+87 ; ----- END IHS/MSC/MKK - LR*5.2*1035
+88 ;
+89 ; IHS/MSC/MKK - LR*5.2*1034
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 7.0")
+90 ;
+91 IF +$GET(COMPD)>2000000
QUIT $$FMTE^XLFDT(COMPD,"2MZ")
+92 ;
+93 ; IHS/MSC/MKK - LR*5.2*1035
DO ENTRYAUD^BLRUTIL("GETCOMPD^BLRUTIL4 8.0")
+94 ;
+95 ; All results dates checked and nothing found, so quit with null
+96 QUIT " "
+97 ;
+98 ;
ENTRYAUD(LABEL,TMPNODE) ; EP - Audit ^TMP global
+1 NEW ENTRYNUM,NOW,NOWTIM
+2 ;
+3 SET NOW=$$NOW^XLFDT
+4 SET ENTRYNUM=$GET(^BLRENTRY)+1
+5 SET $PIECE(^BLRENTRY,U)=ENTRYNUM
+6 MERGE ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL_" ^TMP")=^TMP(TMPNODE)
+7 QUIT
+8 ;
+9 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+10 ; Given an UID, return the LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT variables
RETACCV(UID,LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT,LRAS) ; EP
+1 ; Initialize all the variables
SET (LRAA,LRAD,LRAN,LRAS,LRDFN,LRSS,LRIDT)=""
+2 ;
+3 SET X=$QUERY(^LRO(68,"C",UID,0))
+4 ; Skip if no accession data
IF $LENGTH(X)<1
QUIT
+5 ;
+6 SET LRAA=+$QSUBSCRIPT(X,4)
SET LRAD=+$QSUBSCRIPT(X,5)
SET LRAN=+$QSUBSCRIPT(X,6)
+7 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+8 SET LRSS=$$GET1^DIQ(68,LRAA,.09,"I")
+9 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+10 ;
+11 SET LRAS=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,"ACCESSION")
+12 QUIT
+13 ;
SETUCUM ; EP - Set value into IHS UCUM dictionary
+1 NEW FDA,IEN,UCUM,UDESC,UPRNITN
+2 ;
+3 WRITE !!
+4 ;
+5 SET UCUM=$$GETSTRNG("UCUM Definitiion")
+6 IF UCUM="Q"
QUIT
+7 ;
+8 SET UDESC=$$GETSTRNG("UCUM Description")
+9 IF UDESC="Q"
QUIT
+10 ;
+11 SET UPRINTN=$$GETSTRNG("UCUM Print Name")
+12 IF UPRINTN="Q"
QUIT
+13 ;
+14 SET FDA(90475.3,"+1,",.01)=UCUM
+15 SET FDA(90475.3,"+1,",1)=UDESC
+16 SET FDA(90475.3,"+1,",3)=UPRINTN
+17 ;
+18 DO UPDATE^DIE("S","FDA",,"ERRS")
+19 ;
+20 IF $DATA(ERRS)
Begin DoDot:1
+21 WRITE !,?4,"Error adding UCUM. Error Message Follows:"
+22 DO ARRYDUMP("ERRS")
+23 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+24 ;
+25 SET IEN=$$FIND1^DIC(90475.3,,,UCUM)
+26 KILL FDA,ERRS
+27 SET FDA(90475.32,"+1,"_IEN_",",.01)=UPRINTN
+28 DO UPDATE^DIE("S","FDA",,"ERRS")
+29 ;
+30 IF $DATA(ERRS)
Begin DoDot:1
+31 WRITE !,?4,"Error adding ",UPRINTN," as a SYNONYM. Error Message Follows:"
+32 DO ARRYDUMP("ERRS")
+33 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+34 ;
+35 WRITE !!,?4,"Succesfully added UCUM at IEN:",IEN,!
+36 DO PRESSKEY^BLRGMENU(9)
+37 ;
+38 QUIT
+39 ;
GETSTRNG(STR) ; EP
+1 DO ^XBFMK
+2 SET DIR(0)="FO"
+3 SET DIR("A")=STR
+4 DO ^DIR
+5 IF $GET(X)=""!(+$GET(DIRUT))
Begin DoDot:1
+6 WRITE !!,?4,"No/Invalid/Quit Entry. Routine Ends."
+7 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT "Q"
+8 ;
+9 QUIT $GET(X)
+10 ;
+11 ; "Dump" an array
ARRYDUMP(ARRY) ; EP
+1 NEW COL,MESSAGE,STR1,TOOWIDE,WIDTH
+2 ;
+3 SET STR1=$QUERY(@ARRY@(""))
+4 SET MESSAGE=@STR1
+5 ;
+6 WRITE !,?5,ARRY,!
+7 WRITE ?10,STR1,"="
+8 SET COL=$X
+9 DO ARRYDMP2(COL,MESSAGE)
+10 ;
+11 FOR
SET STR1=$QUERY(@STR1)
IF STR1=""
QUIT
Begin DoDot:1
+12 SET MESSAGE=@STR1
+13 WRITE ?10,STR1,"="
+14 SET COL=$X
+15 DO ARRYDMP2(COL,MESSAGE)
End DoDot:1
+16 QUIT
+17 ;
ARRYDMP2(COL,MESSAGE) ; EP - Output string. If too wide, wrap it.
+1 SET WIDTH=(IOM-COL-1)
+2 SET TOOWIDE=$SELECT((COL+$LENGTH(MESSAGE))<IOM:0,1:1)
+3 ;
+4 IF 'TOOWIDE
WRITE MESSAGE,!
QUIT
+5 ;
+6 IF TOOWIDE
DO LINEWRAP^BLRGMENU(COL,MESSAGE,WIDTH)
WRITE !
+7 QUIT
+8 ;
NOPCEINS ; EP - NO PCE INStalled notice
+1 WRITE !,?4,"VA Patient Encounter module does NOT exist on this sytem."
+2 DO PRESSKEY^BLRGMENU
+3 QUIT
+4 ; ----- END IHS/MSC/MKK - LR*5.2*1033
