BLRUTIL3.m

BLRUTIL3 ;IHS/OIT/MKK - MISC IHS LAB UTILITIES (Cont) ; 04-Apr-2016 14:28 ; MKK

 ;;5.2;IHS LABORATORY;**1025,1027,1030,1031,1033,1039**;NOV 01, 1997;Build 38

 ;

 Q

 ;

 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1025

GETACCCP(LRAS,LRAA,LRAD,LRAN) ; EP -- Take Accession # & break apart

 ; Parse and process user input.  Cloned from LRWU4.

 NEW LRIDIV,LRQUIT,LRX,X1,X2,X3

 S LRX=LRAS

 ;

 S (LRAA,LRAD,LRAN)=""

 ;

 S (X1,X2,X3)="",X1=$P(LRX," ",1),X2=$P(LRX," ",2),X3=$P(LRX," ",3)

 S:X3=""&(+X2=X2) X3=X2,X2=""

 I X1'?1A.AN Q 0

 ;

 S LRAA=$O(^LRO(68,"B",X1,0))

 I LRAA<1 Q 0

 ;

 ; S %=$P(^LRO(68,LRAA,0),U,14)     ; Don't bother with Security Check

 ; I $L(%),'$D(^XUSEC(%,DUZ)) Q 0   ; Don't bother with Security Check

 ;

 S LRX=$G(^LRO(68,LRAA,0)),LRIDIV=$S($L($P(LRX,U,19)):$P(LRX,U,19),1:"CP")

 ;

 ; Only accession area identifier, no date or number

 I X2="",X3="" D

 . N %DT

 . S %DT="AP",%DT("A")="  Accession Date: ",%DT("B")="TODAY"

 . ; D DATE^LRWU

 . ; D DATE

 . I $D(DUOUT) Q

 . I Y<1 Q

 . S LRAD=Y

 ;

 ; Convert middle value to FileMan date

 ; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit 

 ; number as middle part of accession then convert to appropriate date.

 I +$G(LRAD)<1 D

 . N %DT

 . I X2="" S X2=DT

 . I X2?4N D

 . . S X2=$E(DT,1,3)_X2

 . . I X2>DT S X2=X2-10000

 . S %DT="P",X=X2

 . D ^%DT

 . I Y>0 S LRAD=Y Q

 I +$G(LRAD)<1 Q 0

 ;

 ; Convert date entered to apropriate date for accession area transform

 S X=$P(^LRO(68,LRAA,0),U,3)

 S LRAD=$S("D"[X:LRAD,X="Y":$E(LRAD,1,3)_"0000","M"[X:$E(LRAD,1,5)_"00","Q"[X:$E(LRAD,1,3)_"0000"+(($E(LRAD,4,5)-1)\3*300+100),1:LRAD)

 ; W:X3>0 "  ",+X3

 ;

 I X3="",$D(LRACC) D

 . N DIR,DIRUT,DUOUT,DTOUT,X,Y

 . S DIR(0)="NO^1:999999",DIR("A")="  Number part of Accession"

 . D ^DIR

 . I Y=""!$D(DIRUT) Q

 . S X3=Y

 ;

 I X3="",$D(LRACC) Q 0

 S LRAN=+X3

 Q 1

 ;

DATE ; EP

 K DTOUT,DUOUT S LREND=0

 ; W !,"DATE",!!,$S($D(%DT("A")):%DT("A"),1:"DATE: "),$S($D(%DT("B")):%DT("B"),1:"TODAY"),"//" R X:DTIME S:X="^" DUOUT=1 S:'$T X="^",DTOUT=1 I $D(DUOUT)!($D(DTOUT)) S LREND=1,Y=-1 Q

 S:X="" X=$S($D(%DT("B")):%DT("B"),1:"T") S:$D(%DT)[0 %DT="E" S:%DT["A" %DT=$P(%DT,"A",1)_$P(%DT,"A",2) S:%DT'["E" %DT="E"_%DT D ^%DT G DATE:X="?"!(Y<1)

 K %DT

 Q

 ;

D2HBOLD(STR) ; EP - Write string DOUBLE HEIGHT & BOLDED

 W !

 W *27,"#3",*27,"[1m",STR,!

 W *27,"#4",*27,"[1m",STR,!

 W *27,"[0m",!                ; Turn OFF all attributes

 Q

 ;

BOLDUNDR(STR) ; EP -- Write string BOLDED & UNDERLINED

 W *27,"[1;4m",STR,*27,"[0m"

 Q

 ;

REVIDEO(STR) ; EP -- Write string in Reverse Video & BOLDED

 W *27,"[1;7m",STR,*27,"[0m"

 Q

 ; ----- END IHS/OIT/MKK LR*5.2*1025

 ;

 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1027

ESIGINFO ; EP -- Rework of BLRUTIL ESIGINFO subroutine.

 NEW DOCDUZ,DOCIEN,ESIGDSTR,REVIEWDV,TAB

 NEW REVSTS

 ;

 ; If E-SIG not turned on, Quit

 I '$$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",+$G(DUZ(2))) Q

 ;

 S DOCIEN=$O(^VA(200,"B",LRDOC,""))      ; LRDOC = Ordering Provider

 ;

 ; If no IEN, Quit. Usually happens when LRDOC="Unknown"

 Q:$G(DOCIEN)=""

 ;

 I '($D(^BLRALAB(9009027.1,DOCIEN,0))#2) W ?56,"NOT E-SIG PARTICIPATING"  Q

 I $P(^BLRALAB(9009027.1,DOCIEN,0),U,7)'="A" W ?53,"INACTIVE E-SIG PARTICIPANT"  Q

 ;

 ;LRSS doesn't exist when doing option 'BLRTASK CUM', so set it.

 S:$G(LRSS)="" LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)

 ;

 S ESIGDSTR=$G(^LR(LRDFN,LRSS,LRIDT,9009027))           ; E-SIG string Data

 ;

 Q:$P(ESIGDSTR,U,2)=""                                  ; NO Signing Physician

 Q:$P(^BLRALAB(9009027.1,$P(ESIGDSTR,U,2),0),U,7)'="A"  ; NOT Active

 ;

 ; REVIEW status Data Values

 S REVIEWDV=$$UP^XLFSTR($P($G(^DD(63.04,.9009025,0)),U,3))

 S REVSTS=$P($P(REVIEWDV,$P(ESIGDSTR,U)_":",2),";")

 ;

 ; Make sure E-SIG STATUS is flush right

 S TAB=IOM-(16+$L(REVSTS))

 W ?TAB,"E-SIG STATUS: ",REVSTS

 ;

 Q:'$P(ESIGDSTR,U,5)                                    ; NO Signed Date

 ;

 Q:REVSTS["NOT REV"                                     ; NOT Reviewed

 ;

 W !?5,"SIGNING PHYSICIAN: "

 W $P($G(^VA(200,$P(ESIGDSTR,U,2),0)),U)

 W !?5,"DATE/TIME RESULT SIGNED: "

 W $TR($$FMTE^XLFDT($P(ESIGDSTR,U,5),"2MZ"),"@"," ")

 Q

 ;

BLINKER(STR) ; EP -- Write string in BOLDED, UNDERLINED, & BLINKING

 W *27,"[1;4;5m",STR,*27,"[0m"

 Q

 ;

 ; Cloned from LR7OSAP1.  Wrap Text in array to ^TMP global

WRAP(ROOT,FMT) ; EP - Wrap text

 I '$L($G(ROOT)) Q ""

 N CCNT,GCNT,INC,LRI,LRINDX,LRTX,SP,X

 S:'$G(FMT) FMT=79

 S LRINDX=0,LRI=0,GCNT=0

 K ^TMP("BLRUTIL3",$J)

 F  S LRI=$O(@ROOT@(LRI)) Q:LRI'>0  D

 . S X=$S($L($G(@ROOT@(LRI))):@ROOT@(LRI),$L($G(@ROOT@(LRI,0))):@ROOT@(LRI,0),1:""),LRINDX=LRINDX+1

 . S X=$$FMT^LR7OSAP1(FMT,.LRINDX,X)

 S LRI=0

 F  S LRI=$O(LRTX(LRI)) Q:'LRI  D LN^LR7OSAP S ^TMP("BLRUTIL3",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LRTX(LRI))

 Q

 ;

 ;

ALERT ; EP

 W !!

 W "Patient Name:",$P(XQADATA,"^"),!

 W "         UID:",$P(XQADATA,"^",2),!

 W "        TEST:",$P(XQADATA,"^",3),!!

 Q

 ; ----- END IHS/OIT/MKK LR*5.2*1027

 ; 

 ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1030

REVBLINK(STR) ; EP - Print string in Bold, Blinking, Reverse Video

 W *27,"[1;7;5m",STR,*27,"[0m"

 Q

 ;

 ; Moved PCC Bulletin code to here in order to standardize messages

 ; BLRBUL=1 SENDS BLRTXLOG BULLETIN

 ; BLRBUL=2 SENDS BLRTXLOGERR BULLETIN

 ; BLRBUL=3 SENDS BLRTXLOG AND BLRTXLOGERR BULLETIN

BULTNS ; EP - Send PCC Bulletin

 Q:BLRPCC["Lab deleted test"      ; If Lab Deleted Test, don't send message.

 ;

 I "13"[BLRBUL D BULTX("BLRTXLOG")  Q:BLRBUL=1

 D BULTX("BLRTXLOGERR")

 Q

 ;

BULTX(BULLETIN)     ; EP - SEND BULLETIN IF PCC ERROR IN FILING

 K XMB                  ; Initialize array

 S Y=""                 ; Initialize variable

 ;

 ; If BLRTXLOG number exists, use ^BLRTXLOG database

 I +$G(BLRLOGDA)>0 D BULTXSET

 ;

 ; If BLRTXLOG number DOES NOT exist, use variables

 I +$G(BLRLOGDA)<1 D BLTXNSET

 ;

 S XMB(7)=$G(BLRLOGDA)  ; BLR Transaction Log Number

 ;

 S XMB(8)=BLRPCC        ; Error Message

 ;

 S XMB=BULLETIN         ; Bulletin to use

 ;

 ; Send the Bulletin

 ; S BLRDUZ=DUZ,DUZ=.5 D ^XMB S DUZ=BLRDUZ

 S XMDUZ="Lab to PCC Link Processor"

 D ^XMB

 ;

 ; Clean up

 K XMB

 Q

 ;

 ; Set bulletin parameters from ^BLRTXLOG global

BULTXSET ; EP 

 NEW COLLDT,LABTIEN,PTPTR

 ;

 S PTPTR=+$P($G(^BLRTXLOG(BLRLOGDA,0)),"^",4)    ; Patient Pointer

 ;

 S XMB(1)=$P($G(^DPT(PTPTR,0)),"^",1)            ; Patient Name

 S XMB(2)=$G(^DPT(PTPTR,"LR"))                   ; LRDFN

 ;

 ; Date of Visit -- Collection Date

 S COLLDT=$P($G(^BLRTXLOG(BLRLOGDA,12)),"^",1)

 S XMB(3)=$$FMTE^XLFDT(COLLDT,"1D")

 ;

 S XMB(4)=$P($G(^BLRTXLOG(BLRLOGDA,11)),"^",3)   ; Order Number

 S XMB(5)=$P($G(^BLRTXLOG(BLRLOGDA,12)),"^",2)   ; Accession Number

 ;

 S LABTIEN=+$P($G(^BLRTXLOG(BLRLOGDA,0)),"^",6)

 S XMB(6)=$P($G(^LAB(60,LABTIEN,0)),"^",1)       ; Lab Test

 ;

 Q

 ;

 ; Set bulletin parameters from variables

BLTXNSET ; EP

 NEW PTPTR

 ;

 S PTPTR=+$G(APCDALVR("APCDPAT"))                ; Patient Pointer

 ;

 S XMB(1)=$P($G(^DPT(PTPTR,0)),"^",1)            ; Patient Name

 S XMB(2)=$G(^DPT(PTPTR,"LR"))                   ; LRDFN

 ;

 ; Visit/Collection Date

 S XMB(3)=$$FMTE^XLFDT($G(APCDALVR("APCDDATE")),"1D")

 ;

 S XMB(4)=$G(BLRORD)                             ; Order Number

 S XMB(5)=$G(BLRACCN)                            ; Accession Number

 S XMB(6)=$P($G(^LAB(60,+$G(BLRTEST),0)),"^",1)  ; Test Description

 ;

 Q

 ;

 ; Get Reference Range for a Test for File 63

 ; Used by MEAG Delta Check

GETREFR(TESTNAME) ; EP

 NEW IEN,MESSAGE,REFL,REFH,SPEC,TARGET,UNITS

 ;

 ; Get Internal Entry Number of Test

 D FIND^DIC(60,,,,TESTNAME,,,,,"TARGET","MESSAGE")

 S IEN=+$G(TARGET("DILIST",2,1))

 Q:IEN<1 "!!!!!!!!"

 ;

 S SPEC=+$O(^LAB(60,IEN,1,0))  ; First Site/Spec

 Q:SPEC<1 "!!!!!!!!"

 ;

 S REFL=$$GET1^DIQ(60.01,SPEC_","_IEN_",",1,"I")

 S REFH=$$GET1^DIQ(60.01,SPEC_","_IEN_",",2,"I")

 S UNITS=$$GET1^DIQ(60.01,SPEC_","_IEN_",",6,"I")

 ;

 ; If UNITS is a pointer to the IHS UCUM file, get units text

 S:+$G(UNITS)>0 UNITS=$P($G(^BLRUCUM(UNITS,0)),"^")

 ;

 Q SPEC_"!"_REFL_"!"_REFH_"!!!!"_UNITS_"!!"

 ;

INSTLRPT ; EP -- Report of ^BLRINSTL global

 NEW CP,CNT,WHO,WHEN

 NEW HEADER,PG,LINES,MAXLINES,QFLG,HD1

 ;

 D INSTLRPI

 ;

 F  S CP=$O(^BLRINSTL("LAB PATCH",CP))  Q:CP<1!(QFLG="Q")  D

 . F  S CNT=$O(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))  Q:CNT<1!(QFLG="Q")  D

 .. D INSTLRPL

 Q

 ;

INSTLRPI ; EP -- Initialize variables

 NEW DTRANGE,FIRST,FIRSTDT,FRSTPTCH,LAST,LASTPTCH

 S HEADER(1)="IHS LAB Patches Report"

 ;

 S FRSTPTCH=$O(^BLRINSTL("LAB PATCH",0))

 S FIRST=$O(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",0))

 S FIRSTDT=$P($G(^BLRINSTL("LAB PATCH",FRSTPTCH,"INSTALLED BY",FIRST,"DATE/TIME")),"@")

 ;

 S LASTPTCH=$O(^BLRINSTL("LAB PATCH","A"),-1)

 S LAST=$O(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY","A"),-1)

 S LASTDT=$P($G(^BLRINSTL("LAB PATCH",LASTPTCH,"INSTALLED BY",LAST,"DATE/TIME")),"@")

 ;

 S HEADER(2)="Patches Installed From "_FIRSTDT_" thru "_LASTDT

 S HEADER(3)=" "

 S $E(HEADER(4),5)="Patch"

 S $E(HEADER(4),15)="Who"

 S $E(HEADER(4),45)="When"

 ;

 S MAXLINES=22,LINES=MAXLINES+10,PG=0,(HD1,QFLG)="NO"

 S (CP,CNT)=0

 Q

 ;

INSTLRPL ; EP -- Line of Data

 I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HD1)  Q:QFLG="Q"

 ;

 W ?4,CP

 W ?14,$G(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT))

 W ?44,$TR($P($G(^BLRINSTL("LAB PATCH",CP,"INSTALLED BY",CNT,"DATE/TIME")),":",1,2),"@"," ")

 W !

 S LINES=LINES+1

 Q

 ;

MAKE132 ; EP - Force Screen to 132 Characters

 W "Setting display to 132 column mode",!

 W $C(27)_"[?3h",!

 W "132 column mode active.",!

 W $TR($J("",132)," ","*"),!

 W !

 S IOM=132

 Q

 ;

MAKE80 ; EP - Force Screen to 80 Characters

 W "Setting display to 80 column mode",!

 W $C(27)_"[?3l",!

 W "80 column mode active.",!

 W $TR($J("",80)," ","*"),!

 W !

 S IOM=80

 Q

 ;

 ; MAILALMI(MESSAGE,MSGARRAY,FROMWHOM) ; EP - send e-MAIL and an Alert to members of the LMI Mail Group

MAILALMI(MESSAGE,MSGARRAY,FROMWHOM,NOUSER) ; EP - IHS/MSC/MKK - LR*5.2*1031 adds the NOUSER parameter

 NEW MAILARRY

 ;

 ; Alert just sends MESSAGE string

 ; D SNDALERT(MESSAGE)

 D SNDALERT(MESSAGE,$G(NOUSER))                       ; IHS/MSC/MKK - LR*5.2*1031

 ;

 ; Setup variables for sending MailMan e-mail

 I $L($G(MSGARRAY(1))) M MAILARRY=MSGARRAY

 ;

 I $L($G(MSGARRAY(1)))<1 D     ; If MSGARRAY null, create generic array

 . S MAILARRY(1)="The Subject of this email is the message:"

 . S MAILARRY(2)="     "_MESSAGE

 ;

 I $G(FROMWHOM)="" S FROMWHOM="RPMS Lab Package"

 ;

 ; D SENDMAIL(MESSAGE,.MAILARRY,FROMWHOM)

 D SENDMAIL(MESSAGE,.MAILARRY,FROMWHOM,$G(NOUSER))    ; IHS/MSC/MKK - LR*5.2*1031

 ;

 I $D(^XTMP("BLRUTIL3"))<1 D

 . S ^XTMP("BLRUTIL3",0)=$$HTFM^XLFDT(+$H+30)_"^"_$$HTFM^XLFDT(+$H)_"^MAILALMI Usage"

 ; M ^XTMP("BLRUTIL3","MAILALMI",$H,"DUZ")=DUZ

 ;

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033

 NEW NOW

 S NOW=$H

 S ^XTMP("BLRUTIL3","MAILALMI",NOW)=$$HTE^XLFDT(NOW,"5MZ")

 M ^XTMP("BLRUTIL3","MAILALMI",NOW,"DUZ")=DUZ

 ; ----- END IHS/MSC/MKK - LR*5.2*1033

 ;

 Q

 ;

 ; SNDALERT(ALERTMSG,NOUSER) ; EP - Send alert to LMI group AND User (if not member of LMI Mail Group)

SNDALERT(ALERTMSG,NOUSER) ; EP - LR*5.2*1031 addes NOUSER parameter

 S XQAMSG=ALERTMSG

 S XQA("G.LMI")=""

 ;

 ; If User not part of LMI Mail Group, send them e-mail also, but

 ; If-And-Only-If the NOUSER variable is null.

 ; S:$$NINLMI(DUZ) XQA(DUZ)=""

 S:$G(NOUSER)=""&($$NINLMI(DUZ)) XQA(DUZ)=""          ; IHS/MSC/MKK - LR*5.2*1031

 ;

 S X=$$SETUP1^XQALERT

 K XQA,XQAMSG

 Q:X

 ;

 NEW SUBSCRPT

 S SUBSCRPT="BLRLINKU Alert^"_+$H_"^"_$J

 S ^XTMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package Alert."

 S ^XTMP(SUBSCRPT,1)="Alert was not sent."

 S ^XTMP(SUBSCRPT,2)="  Message that should have been sent follows:"

 S ^XTMP(SUBSCRPT,3)="     "_ALERTMSG

 S ^XTMP(SUBSCRPT,4)="  ALERT Error Message Follows:"

 S ^XTMP(SUBSCRPT,5)="     "_XQALERR

 Q

 ;

NINLMI(CHKDUZ) ; EP -- Check to see if DUZ is NOT part of LMI Mail Group

 NEW MGRPIEN,XMDUZ

 ;

 ; Get IEN of LMI MaiL Group

 D CHKGROUP^XMBGRP("LMI",.MGRPIEN)  ; VA DBIA 1146

 Q:+(MGRPIEN)<1 1                   ; If no Mail Group, return TRUE

 ;

 ; XMDUZ = DUZ of the user

 ; Y     = IEN of the mail group

 S XMDUZ=DUZ

 S Y=MGRPIEN

 D CHK^XMA21                        ; VA DBIA 10067

 ;

 Q $S($T=1:0,1:1)

 ;

 ; Send MailMan E-mail to LMI group AND User (if User is not a member of LMI Mail Group)

SENDMAIL(MAILMSG,MAILARRY,FROMWHOM,NOUSER) ; EP 

 NEW DIFROM

 ;

 K XMY

 S XMY("G.LMI")=""

 ;

 ; If User not part of LMI Mail Group, send them e-mail also, but

 ; If-And-Only-If the NOUSER variable is null.

 S:$G(NOUSER)=""&($$NINLMI(DUZ)) XMY(DUZ)=""

 ;

 S LRBLNOW=$E($$NOW^XLFDT,1,12)

 ;

 S XMSUB=MAILMSG

 S XMTEXT="MAILARRY("

 S XMDUZ=FROMWHOM

 S XMZ="NOT OKAY"

 D ^XMD

 ;

 I $G(XMMG)'=""!(XMZ="NOT OKAY") D

 . NEW SUBSCRPT,ARRAY

 . S SUBSCRPT="MailMan Message Failure^"_+$H_"^"_$J

 . ; S ^XTEMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package MailMan Message."

 . ; S ^XTEMP(SUBSCRPT,1)="MailMan Message was not sent."

 . ; S ^XTEMP(SUBSCRPT,2)="  Message that should have been sent follows:"

 . ; S ARRAY=0

 . ; F  S ARRAY=$O(MAILARRY(ARRAY))  Q:ARRAY<1  D

 .. ; S ^XTEMP(SUBSCRPT,(ARRAY+3))="     "_$G(MAILARRY(ARRAY))

 . ;

 . ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039 - Use ^XTMP not ^XTEMP, per SAC

 . S ^XTMP(SUBSCRPT,0)=$$FMADD^XLFDT($$DT^XLFDT,90)_"^"_$$DT^XLFDT_"^"_"Lab Package MailMan Message."

 . S ^XTMP(SUBSCRPT,1)="MailMan Message was not sent."

 . S ^XTMP(SUBSCRPT,2)="  Message that should have been sent follows:"

 . S ARRAY=0

 . F  S ARRAY=$O(MAILARRY(ARRAY))  Q:ARRAY<1  D

 .. S ^XTMP(SUBSCRPT,(ARRAY+2))="     "_$G(MAILARRY(ARRAY))

 . ; ----- END IHS/MSC/MKK - LR*5.2*1039

 ;

 K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y   ; Cleanup

 Q

 ;

 ; ----- END IHS/OIT/MKK -- LR*5.2*1030

 ;

 ; ----- BEGIN IHS/MSC/MKK -- LR*5.2*1031

TESTMAIL ; EP

 NEW DIFROM,STR

 ;

 S STR(1)="SINGLE LINE OF TEXT"

 ;

 K XMY

 S XMY("G.LMI")=""

 S XMSUB="TESTING MAILMAN"

 S XMTEXT="STR("

 S XMDUZ=DUZ

 S XMZ="NOT OKAY"

 D ^XMD

 ;

 W "XMZ:",XMZ,!

 W "XMMG:",$G(XMMG),!

 ;

 K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y   ; Cleanup

 Q

 ; ----- END IHS/MSC/MKK -- LR*5.2*1031

BLRUTIL3  ;IHS/OIT/MKK - MISC IHS LAB UTILITIES (Cont) ; 04-Apr-2016 14:28 ; MKK

 +1       ;;5.2;IHS LABORATORY;**1025,1027,1030,1031,1033,1039**;NOV 01, 1997;Build 38

 +2       ;

 +3        QUIT 

 +4       ;

 +5       ; ----- BEGIN IHS/OIT/MKK LR*5.2*1025

GETACCCP(LRAS,LRAA,LRAD,LRAN) ; EP -- Take Accession # & break apart

 +1       ; Parse and process user input.  Cloned from LRWU4.

 +2        NEW LRIDIV,LRQUIT,LRX,X1,X2,X3

 +3        SET LRX=LRAS

 +4       ;

 +5        SET (LRAA,LRAD,LRAN)=""

 +6       ;

 +7        SET (X1,X2,X3)=""

           SET X1=$PIECE(LRX," ",1)

           SET X2=$PIECE(LRX," ",2)

           SET X3=$PIECE(LRX," ",3)

 +8        IF X3=""&(+X2=X2)

               SET X3=X2

               SET X2=""

 +9        IF X1'?1A.AN

               QUIT 0

 +10      ;

 +11       SET LRAA=$ORDER(^LRO(68,"B",X1,0))

 +12       IF LRAA<1

               QUIT 0

 +13      ;

 +14      ; S %=$P(^LRO(68,LRAA,0),U,14)     ; Don't bother with Security Check

 +15      ; I $L(%),'$D(^XUSEC(%,DUZ)) Q 0   ; Don't bother with Security Check

 +16      ;

 +17       SET LRX=$GET(^LRO(68,LRAA,0))

           SET LRIDIV=$SELECT($LENGTH($PIECE(LRX,U,19)):$PIECE(LRX,U,19),1:"CP")

 +18      ;

 +19      ; Only accession area identifier, no date or number

 +20       IF X2=""

               IF X3=""

                   Begin DoDot:1

 +21                   NEW %DT

 +22                   SET %DT="AP"

                       SET %DT("A")="  Accession Date: "

                       SET %DT("B")="TODAY"

 +23      ; D DATE^LRWU

 +24      ; D DATE

 +25                   IF $DATA(DUOUT)

                           QUIT 

 +26                   IF Y<1

                           QUIT 

 +27                   SET LRAD=Y

                   End DoDot:1

 +28      ;

 +29      ; Convert middle value to FileMan date

 +30      ; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit 

 +31      ; number as middle part of accession then convert to appropriate date.

 +32       IF +$GET(LRAD)<1

               Begin DoDot:1

 +33               NEW %DT

 +34               IF X2=""

                       SET X2=DT

 +35               IF X2?4N

                       Begin DoDot:2

 +36                       SET X2=$EXTRACT(DT,1,3)_X2

 +37                       IF X2>DT

                               SET X2=X2-10000

                       End DoDot:2

 +38               SET %DT="P"

                   SET X=X2

 +39               DO ^%DT

 +40               IF Y>0

                       SET LRAD=Y

                       QUIT 

               End DoDot:1

 +41       IF +$GET(LRAD)<1

               QUIT 0

 +42      ;

 +43      ; Convert date entered to apropriate date for accession area transform

 +44       SET X=$PIECE(^LRO(68,LRAA,0),U,3)

 +45       SET LRAD=$SELECT("D"[X:LRAD,X="Y":$EXTRACT(LRAD,1,3)_"0000","M"[X:$EXTRACT(LRAD,1,5)_"00","Q"[X:$EXTRACT(LRAD,1,3)_"0000"+(($EXTRACT(LRAD,4,5)-1)\3*300+100),1:LRAD)

 +46      ; W:X3>0 "  ",+X3

 +47      ;

 +48       IF X3=""

               IF $DATA(LRACC)

                   Begin DoDot:1

 +49                   NEW DIR,DIRUT,DUOUT,DTOUT,X,Y

 +50                   SET DIR(0)="NO^1:999999"

                       SET DIR("A")="  Number part of Accession"

 +51                   DO ^DIR

 +52                   IF Y=""!$DATA(DIRUT)

                           QUIT 

 +53                   SET X3=Y

                   End DoDot:1

 +54      ;

 +55       IF X3=""

               IF $DATA(LRACC)

                   QUIT 0

 +56       SET LRAN=+X3

 +57       QUIT 1

 +58      ;

DATE      ; EP

 +1        KILL DTOUT,DUOUT

           SET LREND=0

 +2       ; W !,"DATE",!!,$S($D(%DT("A")):%DT("A"),1:"DATE: "),$S($D(%DT("B")):%DT("B"),1:"TODAY"),"//" R X:DTIME S:X="^" DUOUT=1 S:'$T X="^",DTOUT=1 I $D(DUOUT)!($D(DTOUT)) S LREND=1,Y=-1 Q

 +3        IF X=""

               SET X=$SELECT($DATA(%DT("B")):%DT("B"),1:"T")

           IF $DATA(%DT)[0

               SET %DT="E"

           IF %DT["A"

               SET %DT=$PIECE(%DT,"A",1)_$PIECE(%DT,"A",2)

           IF %DT'["E"

               SET %DT="E"_%DT

           DO ^%DT

           IF X="?"!(Y<1)

               GOTO DATE

 +4        KILL %DT

 +5        QUIT 

 +6       ;

D2HBOLD(STR) ; EP - Write string DOUBLE HEIGHT & BOLDED

 +1        WRITE !

 +2        WRITE *27,"#3",*27,"[1m",STR,!

 +3        WRITE *27,"#4",*27,"[1m",STR,!

 +4       ; Turn OFF all attributes

           WRITE *27,"[0m",!

 +5        QUIT 

 +6       ;

BOLDUNDR(STR) ; EP -- Write string BOLDED & UNDERLINED

 +1        WRITE *27,"[1;4m",STR,*27,"[0m"

 +2        QUIT 

 +3       ;

REVIDEO(STR) ; EP -- Write string in Reverse Video & BOLDED

 +1        WRITE *27,"[1;7m",STR,*27,"[0m"

 +2        QUIT 

 +3       ; ----- END IHS/OIT/MKK LR*5.2*1025

 +4       ;

 +5       ; ----- BEGIN IHS/OIT/MKK LR*5.2*1027

ESIGINFO  ; EP -- Rework of BLRUTIL ESIGINFO subroutine.

 +1        NEW DOCDUZ,DOCIEN,ESIGDSTR,REVIEWDV,TAB

 +2        NEW REVSTS

 +3       ;

 +4       ; If E-SIG not turned on, Quit

 +5        IF '$$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",+$GET(DUZ(2)))

               QUIT 

 +6       ;

 +7       ; LRDOC = Ordering Provider

           SET DOCIEN=$ORDER(^VA(200,"B",LRDOC,""))

 +8       ;

 +9       ; If no IEN, Quit. Usually happens when LRDOC="Unknown"

 +10       IF $GET(DOCIEN)=""

               QUIT 

 +11      ;

 +12       IF '($DATA(^BLRALAB(9009027.1,DOCIEN,0))#2)

               WRITE ?56,"NOT E-SIG PARTICIPATING"

               QUIT 

 +13       IF $PIECE(^BLRALAB(9009027.1,DOCIEN,0),U,7)'="A"

               WRITE ?53,"INACTIVE E-SIG PARTICIPANT"

               QUIT 

 +14      ;

 +15      ;LRSS doesn't exist when doing option 'BLRTASK CUM', so set it.

 +16       IF $GET(LRSS)=""

               SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)

 +17      ;

 +18      ; E-SIG string Data

           SET ESIGDSTR=$GET(^LR(LRDFN,LRSS,LRIDT,9009027))

 +19      ;

 +20      ; NO Signing Physician

           IF $PIECE(ESIGDSTR,U,2)=""

               QUIT 

 +21      ; NOT Active

           IF $PIECE(^BLRALAB(9009027.1,$PIECE(ESIGDSTR,U,2),0),U,7)'="A"

               QUIT 

 +22      ;

 +23      ; REVIEW status Data Values

 +24       SET REVIEWDV=$$UP^XLFSTR($PIECE($GET(^DD(63.04,.9009025,0)),U,3))

 +25       SET REVSTS=$PIECE($PIECE(REVIEWDV,$PIECE(ESIGDSTR,U)_":",2),";")

 +26      ;

 +27      ; Make sure E-SIG STATUS is flush right

 +28       SET TAB=IOM-(16+$LENGTH(REVSTS))

 +29       WRITE ?TAB,"E-SIG STATUS: ",REVSTS

 +30      ;

 +31      ; NO Signed Date

           IF '$PIECE(ESIGDSTR,U,5)

               QUIT 

 +32      ;

 +33      ; NOT Reviewed

           IF REVSTS["NOT REV"

               QUIT 

 +34      ;

 +35       WRITE !?5,"SIGNING PHYSICIAN: "

 +36       WRITE $PIECE($GET(^VA(200,$PIECE(ESIGDSTR,U,2),0)),U)

 +37       WRITE !?5,"DATE/TIME RESULT SIGNED: "

 +38       WRITE $TRANSLATE($$FMTE^XLFDT($PIECE(ESIGDSTR,U,5),"2MZ"),"@"," ")

 +39       QUIT 

 +40      ;

BLINKER(STR) ; EP -- Write string in BOLDED, UNDERLINED, & BLINKING

 +1        WRITE *27,"[1;4;5m",STR,*27,"[0m"

 +2        QUIT 

 +3       ;

 +4       ; Cloned from LR7OSAP1.  Wrap Text in array to ^TMP global

WRAP(ROOT,FMT) ; EP - Wrap text

 +1        IF '$LENGTH($GET(ROOT))

               QUIT ""

 +2        NEW CCNT,GCNT,INC,LRI,LRINDX,LRTX,SP,X

 +3        IF '$GET(FMT)

               SET FMT=79

 +4        SET LRINDX=0

           SET LRI=0

           SET GCNT=0

 +5        KILL ^TMP("BLRUTIL3",$JOB)

 +6        FOR 

               SET LRI=$ORDER(@ROOT@(LRI))

               IF LRI'>0

                   QUIT 

               Begin DoDot:1

 +7                SET X=$SELECT($LENGTH($GET(@ROOT@(LRI))):@ROOT@(LRI),$LENGTH($GET(@ROOT@(LRI,0))):@ROOT@(LRI,0),1:"")

                   SET LRINDX=LRINDX+1

 +8                SET X=$$FMT^LR7OSAP1(FMT,.LRINDX,X)

               End DoDot:1

 +9        SET LRI=0

 +10       FOR 

               SET LRI=$ORDER(LRTX(LRI))

               IF 'LRI

                   QUIT 

               DO LN^LR7OSAP

               SET ^TMP("BLRUTIL3",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LRTX(LRI))

 +11       QUIT 

 +12      ;

 +13      ;

ALERT     ; EP

 +1        WRITE !!

 +2        WRITE "Patient Name:",$PIECE(XQADATA,"^"),!

 +3        WRITE "         UID:",$PIECE(XQADATA,"^",2),!

 +4        WRITE "        TEST:",$PIECE(XQADATA,"^",3),!!

 +5        QUIT 

 +6       ; ----- END IHS/OIT/MKK LR*5.2*1027

 +7       ; 

 +8       ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1030

REVBLINK(STR) ; EP - Print string in Bold, Blinking, Reverse Video

 +1        WRITE *27,"[1;7;5m",STR,*27,"[0m"

 +2        QUIT 

 +3       ;

 +4       ; Moved PCC Bulletin code to here in order to standardize messages

 +5       ; BLRBUL=1 SENDS BLRTXLOG BULLETIN

 +6       ; BLRBUL=2 SENDS BLRTXLOGERR BULLETIN

 +7       ; BLRBUL=3 SENDS BLRTXLOG AND BLRTXLOGERR BULLETIN

BULTNS    ; EP - Send PCC Bulletin

 +1       ; If Lab Deleted Test, don't send message.

           IF BLRPCC["Lab deleted test"

               QUIT 

 +2       ;

 +3        IF "13"[BLRBUL

               DO BULTX("BLRTXLOG")

               IF BLRBUL=1

                   QUIT 

 +4        DO BULTX("BLRTXLOGERR")

 +5        QUIT 

 +6       ;

BULTX(BULLETIN) ; EP - SEND BULLETIN IF PCC ERROR IN FILING

 +1       ; Initialize array

           KILL XMB

 +2       ; Initialize variable

           SET Y=""

 +3       ;

 +4       ; If BLRTXLOG number exists, use ^BLRTXLOG database

 +5        IF +$GET(BLRLOGDA)>0

               DO BULTXSET

 +6       ;

 +7       ; If BLRTXLOG number DOES NOT exist, use variables

 +8        IF +$GET(BLRLOGDA)<1

               DO BLTXNSET

 +9       ;

 +10      ; BLR Transaction Log Number

           SET XMB(7)=$GET(BLRLOGDA)

 +11      ;

 +12      ; Error Message

           SET XMB(8)=BLRPCC

 +13      ;

 +14      ; Bulletin to use

           SET XMB=BULLETIN

 +15      ;

 +16      ; Send the Bulletin

 +17      ; S BLRDUZ=DUZ,DUZ=.5 D ^XMB S DUZ=BLRDUZ

 +18       SET XMDUZ="Lab to PCC Link Processor"

 +19       DO ^XMB

 +20      ;

 +21      ; Clean up

 +22       KILL XMB

 +23       QUIT 

 +24      ;

 +25      ; Set bulletin parameters from ^BLRTXLOG global

BULTXSET  ; EP 

 +1        NEW COLLDT,LABTIEN,PTPTR

 +2       ;

 +3       ; Patient Pointer

           SET PTPTR=+$PIECE($GET(^BLRTXLOG(BLRLOGDA,0)),"^",4)