BLRUTIL4.m

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")