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

BLRAGUT.m

Go to the documentation of this file.
  1. BLRAGUT ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPC UTILITIES ; 22-Oct-2015 07:58 ; MKK
  1. ;;5.2;IHS LABORATORY;**1031,1037,1039**;NOV 01, 1997;Build 38
  1. ;
  1. ; UTILITIES (BGOUTL)
  1. ; GACE = get accession number external for given test
  1. ; GACE69 = get accession number external for given pointers to file 69
  1. ; CVTDATE = Convert date to internal format
  1. ; ERR = Error logging routine
  1. ; ERROR = General error catch routine used by @^%ZOSF("TRAP")
  1. ; FILL = Pad end of string with given character (default to space)
  1. ; LEXLKUP = Perform lookup in lexicon
  1. ; PREP = prep input for partial name lookup
  1. ; PTC = return the value of the BLR PT CONFIRM parameter
  1. ; TEST = Returns true if routine exists
  1. ; TMPGLB = return name of global array
  1. ; UPS = upshift and check punctuation of input
  1. ;
  1. GACE(AREA,DATE,ACI) ; EP - get accession number external for given test
  1. ; AREA = area pointer to ACCESSION file 68
  1. ; DATE = date pointer to ACCESSION file 68 - ^LRO(68,AREA,1,DATE
  1. ; ACI = internal accession pointer to ACCESSION file 68 - ^LRO(68,AREA,1,DATE,1,ACI
  1. Q:$G(AREA)=""
  1. Q:$G(DATE)=""
  1. Q:$G(ACI)=""
  1. Q $P($G(^LRO(68,AREA,1,DATE,1,ACI,.2)),U,1)
  1. Q
  1. ;
  1. GACE69(ODATE,OSPEC,OTST) ; EP - get accession number external for given test from file 69
  1. ; ODATE = date pointer to LAB ORDER ENTRY file 69 - ^LRO(69,DATE
  1. ; OSPEC = specimen pointer to LAB ORDER ENTRY file 69 - ^LRO(69,DATE,1,SPEC
  1. ; OTST = test pointer to LAB ORDER ENTRY file 69 - ^LRO(69,DATE,1,SPEC,2,TST
  1. Q:$G(ODATE)=""
  1. Q:$G(OSPEC)=""
  1. Q:$G(OTST)=""
  1. N AREA,DATE,ACI,NODT69
  1. S NODT69=$G(^LRO(69,ODATE,1,OSPEC,2,OTST,0))
  1. S AREA=$P(NODT69,U,4)
  1. S DATE=$P(NODT69,U,3)
  1. S ACI=$P(NODT69,U,5)
  1. Q $S((AREA'="")&(DATE'="")&(ACI'=""):$P($G(^LRO(68,AREA,1,DATE,1,ACI,.2)),U,1),1:"")
  1. Q
  1. ;
  1. ; Convert date to internal format
  1. CVTDATE(X) ; EP
  1. Q:"@"[X X
  1. S:X?1.E1" "1.2N1":"2N.E X=$P(X," ")_"@"_$P(X," ",2,99)
  1. D DT^DILF("PT",X,.X)
  1. Q $S(X>0:X,1:"")
  1. ;
  1. ERR(BLRERR) ; EP - Error processing
  1. ; BLRERR = Error text OR error code
  1. ; BLRI = pointer into return global array
  1. ;
  1. D FORCEIT^BLRUTIL7("ERR^BLRAGUT")
  1. ;
  1. I +BLRERR S BLRERR=BLRERR+134234112 ;vbObjectError
  1. S BLRI=BLRI+1
  1. S ^TMP("BLRAG",$J,BLRI)=BLRERR_$C(30)
  1. ;S BLRI=BLRI+1
  1. ;S ^TMP("BLRAG",$J,BLRI)=$C(31)
  1. Q
  1. ;
  1. ERROR ; EP
  1. ; D ENTRYAUD^BLRUTIL("ERROR^BLRAGUT 0.0") ; Store RPMS Error data
  1. ; NEW ERRORMSG
  1. ; S ERRORMSG="$"_"Z"_"E=""ERROR^BLRAGUT""" ; BYPASS SAC Checker
  1. ; S @ERRORMSG D ^%ZTER
  1. ;
  1. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1037
  1. NEW ERRSCFL,ERRCODE,LASTGLOR
  1. S ERRCODE=$$EC^%ZOSV ; Error Code
  1. S ERRLGLO=$$LGR^%ZOSV ; Last Global accessed
  1. ; D FORCEIT^BLRUTIL7("ERROR^BLRAGUT 0.0")
  1. ; ----- END IHS/MSC/MKK - LR*5.2*1037
  1. ;
  1. ; D ERR("RPMS Error")
  1. D ERR("RPMS Error: "_ERRCODE) ; IHS/MSC/MKK - LR*5.2*1039
  1. Q
  1. ;
  1. FILL(PADS,CHAR=" ") ; EP
  1. N I
  1. S RET=""
  1. F I=1:1:PADS S RET=RET_CHAR
  1. Q RET
  1. ;
  1. ; Perform lookup in lexicon
  1. ; INP = Term ^ Type (ICD/CHP)
  1. LEXLKUP(RET,INP) ; EP
  1. N TERM,TYPE
  1. Q:'$$TEST("LEX^ORWPCE",.RET)
  1. S TERM=$P(INP,U)
  1. Q:TERM=""
  1. S TYPE=$P(INP,U,2)
  1. Q:TYPE=""
  1. D LEX^ORWPCE(.RET,TERM,TYPE)
  1. Q
  1. ;
  1. PREP(NAME) ; EP - prep input for partial name lookup - decrement last char of name for $O; up-shift all alpha characters
  1. N BLRL
  1. Q:$G(NAME)="" -1
  1. S NAME=$$UPS(NAME)
  1. Q:$E(NAME,$L(NAME))'?1A NAME
  1. S BLRL=$E(NAME,$L(NAME))
  1. S BLRL=$A(BLRL)-1
  1. Q $E(NAME,1,$L(NAME)-1)_$C(BLRL)_"~"
  1. ;
  1. PTC() ; EP - return the value of the BLR PT CONFIRM parameter
  1. ; Returns Patient Confirmation enabled; 0='no' (default); 1='yes'
  1. N BLRDOM,BLRENT,BLRI,BLRPAR
  1. ;K ^TMP("BLRAG",$J)
  1. ;D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
  1. ;S BLRI=0
  1. ;S BLRY="^TMP(""BLRAG"","_$J_")"
  1. ;S ^TMP("BLRAG",$J,BLRI)="T00020PT_CONFIRM"_$C(30)
  1. S BLRDOM=$$GET1^DIQ(8989.3,"1,",.01,"I")
  1. S BLRENT=BLRDOM_";"_"DIC(4.2,"
  1. S BLRPAR=$O(^XTV(8989.51,"B","BLR PT CONFIRM",0))
  1. S BLRRET=$$GET^XPAR(BLRENT,BLRPAR,1,"Q")
  1. Q $S(BLRRET'="":BLRRET,1:0)
  1. ;
  1. ; Returns true if routine exists
  1. ; X = Routine or routine^tag
  1. ; .Y error message returned if not found
  1. TEST(X,Y) ; EP
  1. S:X[U X=$P(X,U,2)
  1. Q:'$L(X)!(X'?.1"%"1.AN) 0
  1. X ^%ZOSF("TEST")
  1. Q:$T 1
  1. S Y=$$ERR("1059:"_X)
  1. Q 0
  1. ;
  1. TMPGLB() ; EP
  1. K ^TMP("BLRAG",$J)
  1. Q $NA(^TMP("BLRAG",$J))
  1. ;
  1. UPS(NAME) ; EP - upshift and check punctuation of input
  1. N BLRDGC,BLRDGI
  1. F BLRDGI=1:1:$L(NAME) S BLRDGC=$E(NAME,BLRDGI) D:$$FC1^DPTNAME1(.BLRDGC,1)
  1. .S NAME=$E(NAME,0,BLRDGI-1)_BLRDGC_$E(NAME,BLRDGI+1,999)
  1. .Q
  1. Q NAME
  1. ;
  1. QS(BLRROOT,BLRN) ; EP
  1. ;replace $QS calls; SAC checker does not like $QS
  1. ;this routine does not handle intexpr (BLRN) <0
  1. S BLRRET=""
  1. I BLRN=1 Q $P($P($P(BLRROOT,",",1),"(",2),")",1)
  1. I BLRN>1 Q $P($P(BLRROOT,",",2),")",1)
  1. I BLRN=0 Q $P(BLRROOT,"(",1)
  1. Q ""
  1. ;
  1. DEVICE(BDGXY) ; EP List of printers
  1. ; OUTPUT:
  1. ; BDGXY(n)=REPORT TEXT
  1. ;
  1. N BDGII,FROM,DIR
  1. S BDGII=0
  1. S BDGXY=$$TMPGLB^BLRAGUT()
  1. S @BDGXY@(BDGII)="I00030PRINTER_IEN^T00040PRINTER_NAME"
  1. N CNT,IEN,X,Y,X0,XLOC,XSEC,XTYPE,XSTYPE,XTIME,XOSD,MW,PL,DEV
  1. S FROM="",DIR=1
  1. F S FROM=$O(^%ZIS(1,"B",FROM),DIR),IEN=0 Q:FROM="" D
  1. .F S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN D
  1. ..S DEV="",X0=$G(^%ZIS(1,IEN,0)),XLOC=$P($G(^(1)),U),XOSD=+$G(^(90)),MW=$G(^(91)),XSEC=$G(^(95)),XSTYPE=+$G(^("SUBTYPE")),XTIME=$P($G(^("TIME")),U),XTYPE=$P($G(^("TYPE")),U)
  1. ..Q:$E($G(^%ZIS(2,XSTYPE,0)))'="P" ; Printers only
  1. ..Q:"^TRM^HG^CHAN^OTH^"'[(U_XTYPE_U)
  1. ..Q:$P(X0,U,2)="0"!($P(X0,U,12)=2) ; Queuing allowed
  1. ..I XOSD,XOSD'>DT Q ; Out of Service
  1. ..I $L(XTIME) D Q:'$L(XTIME) ; Prohibited Times
  1. ...S Y=$P($H,",",2),Y=Y\60#60+(Y\3600*100),X=$P(XTIME,"-",2)
  1. ...S:X'<XTIME&(Y'>X&(Y'<XTIME))!(X<XTIME&(Y'<XTIME!(Y'>X))) XTIME=""
  1. ..I $L(XSEC),$G(DUZ(0))'="@",$TR(XSEC,$G(DUZ(0)))=XSEC Q
  1. ..S PL=$P(MW,U,3),MW=$P(MW,U),X=$G(^%ZIS(2,XSTYPE,1))
  1. ..S:'MW MW=$P(X,U)
  1. ..S:'PL PL=$P(X,U,3)
  1. ..S X=$P(X0,U)
  1. ..Q:$E(X,1,4)["NULL"
  1. ..S:X'=FROM X=FROM_" <"_X_">"
  1. ..S BDGII=BDGII+1,@BDGXY@(BDGII)=IEN_U_$P(X0,U)
  1. Q
  1. ;
  1. SETVARS() ; EP - Set the necessary variables for BLREVTQ to work
  1. S LRAS=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)) ; Get Accession
  1. I $L(LRAS)<1 Q $$WHYNOT("<NULL>","Accession string does not exist")
  1. ;
  1. I +$O(^BLRTXLOG("D",LRAS,0)) Q $$WHYNOT(LRAS,"Accession already in ^BLRTXLOG")
  1. ;
  1. S LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
  1. I LRSS'="CH"&(LRSS'="MI") Q $$WHYNOT(LRAS,"Accession not 'CH' nor 'MI' Subscript")
  1. ;
  1. S ORIGACCD=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3) ; Original Accession Date
  1. I ORIGACCD<YEARAGO Q $$WHYNOT(LRAS,"Original Accession Date More than a Year Ago")
  1. ;
  1. S ORDNUM=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)) ; Order Number
  1. I ORDNUM<1 Q $$WHYNOT(LRAS,"Order Number does not exist")
  1. ;
  1. S LRODT=+$O(^LRO(69,"C",ORDNUM,0))
  1. I LRODT<1 Q $$WHYNOT(LRAS,"Order Number "_ORDNUM_"'s Order Date does not exist for "_LRAD_" Accession Date")
  1. ;
  1. S LRSN=+$O(^LRO(69,"C",ORDNUM,LRODT,0))
  1. I LRSN<1 Q $$WHYNOT(LRAS,"Order Date's LRSN:"_LRSN_" does not exist")
  1. ;
  1. S DTTRAVIL=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",4) ; Date/Time Results Available
  1. I +DTTRAVIL<1 Q $$WHYNOT(LRAS,"No 'Results Available' Date")
  1. ;
  1. S LRCDT=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) ; Collection Date/Time
  1. ;
  1. I $$PCCVFILE(LRAA,LRAS,LRCDT,LRSS,.PCCVISIT) Q $$WHYNOT(LRAS,"PCC Visit "_PCCVISIT_" Matched "_$P(LRCDT,".")_" Collection Date.")
  1. ;
  1. S (D0,DA,LRIDT)=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5) ; Inverse Date
  1. ;
  1. S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1. S DFN=+$P($G(^LR(LRDFN,0)),"^",3)
  1. I DFN<1 Q $$WHYNOT(LRAS,"LRDFN "_LRDFN_" has no DFN.")
  1. ;
  1. D DFN^LRDAGE(DFN,2,LRCDT)
  1. S (BID,HRCN,PID)=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),"^",2)
  1. S PNM=$P($G(^DPT(DFN,0)),"^"),STR=$RE($P($G(^(0)),"^",9))
  1. S SSN=$RE($E(STR,7,9))_"-"_$RE($E(STR,5,6))_"-"_$RE($E(STR,1,4))
  1. ;
  1. S BLRCMF="M",BLRDH=+$H,BLRLOG=1,BLRPCC=1
  1. S BLROPT="BYPASS" ; Set to BYPASS because its already resulted
  1. S BLRPHASE="R" ; Set phase to RESULTing
  1. S BLRQSITE=DUZ(2),BLRQUIET=1,BLRSTOP=0
  1. S (BLRIDS,LRACC)=LRAS
  1. ;
  1. S STR=$$FMTE^XLFDT(LRCDT,"2M")
  1. S LRDAT=$P(STR,"/",1,2)_" "_$TR($P(STR,"@",2),":")_"d"
  1. ;
  1. S (LRACD,LRAOD)=LRAD
  1. S LRDT0=$$HTE^XLFDT($H,"2D")
  1. S LRLABKY="1^1^1^1"
  1. S LRLOCKER="^LR("_LRDFN_","_$C(34)_LRSS_$C(34)_","_LRIDT_")"
  1. S LROUTINE=9,LRPANEL=0,LRPCEVSO=1
  1. ;
  1. S PTR=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",8),LRLLOC=$P($G(^(0)),"^",7)
  1. S LRPRAC=$P($G(^VA(200,PTR,0)),"^")
  1. ;
  1. S PTR=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",10)
  1. ;
  1. S LRUID=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1. ;
  1. S STR=$G(^VA(200,DUZ,0))
  1. S LRUSI=$P(STR,"^",2)
  1. S LRUSNM=$P(STR,"^")
  1. ;
  1. S BLRPARAM=""
  1. Q "OK"
  1. ;
  1. WHYNOT(LRAS,MESSAGE) ; EP - Store Reason why ^BLREVTQ not called
  1. S ^TMP("BLRPCCRR",$J,"NOSEND",LRAS,$H)=MESSAGE
  1. S NOTSENT=NOTSENT+1
  1. ;
  1. D WHYNCNTM(MESSAGE)
  1. ;
  1. Q:AUTOLOAD "Q"
  1. ;
  1. W !,?4,"Could not set a variable"
  1. W $S($L(LRAS):" for Accession "_LRAS_".",1:"."),!
  1. W ?9,"Error Message:",$E(MESSAGE,1,55),!
  1. D PRESSKEY^BLRGMENU(14)
  1. Q "Q"
  1. ;
  1. PCCVFILE(LRAA,LRAS,LRCDT,LRSS,PCCVISIT) ; EP - Try to determine if Accession already in PCC File
  1. NEW BLRVERN,CDTPCC,FOUNDIT,PCCIEN
  1. ;
  1. S BLRVERN=$P($P($T(+1),";")," ")
  1. ;
  1. S:LRSS="CH" PCCFILE="^AUPNVLAB(""ALR0"","_$C(34)_LRAS_$C(34)_","
  1. S:LRSS="MI" PCCFILE="^AUPNVMIC(""ALR0"","_$C(34)_LRAS_$C(34)_","
  1. ;
  1. S LRCDT=$P(LRCDT,".")
  1. S PCCIEN=.9999999,FOUNDIT=0
  1. F S PCCIEN=$O(@(PCCFILE_PCCIEN_")")) Q:PCCIEN<1!(FOUNDIT) D
  1. . S CDTPCC=$P($P($G(^AUPNVLAB(PCCIEN,12)),"^"),".")
  1. . S:CDTPCC=LRCDT FOUNDIT=PCCIEN
  1. ;
  1. I FOUNDIT S PCCVISIT=FOUNDIT Q 1
  1. ;
  1. Q 0
  1. ;
  1. WHYNCNTM(MESSAGE) ; EP - Just count messages
  1. S MESSAGE=$$UP^XLFSTR(MESSAGE)
  1. ;
  1. I MESSAGE["PCC VISIT",MESSAGE["MATCHED",MESSAGE["COLLECTION DATE" D CNTERRS("PCC VISIT FOUND") Q
  1. I MESSAGE["ACCESSION STRING DOES NOT EXIST" D CNTERRS("ACCESSION STRING DOES NOT EXIST") Q
  1. I MESSAGE["ACCESSION ALREADY IN ^BLRTXLOG" D CNTERRS("ACCESSION ALREADY IN ^BLRTXLOG") Q
  1. I MESSAGE["ACCESSION NOT 'CH' NOR 'MI' SUBSCRIPT" D CNTERRS("ACCESSION NOT 'CH' NOR 'MI' SUBSCRIPT") Q
  1. I MESSAGE["ORDER NUMBER DOES NOT EXIST" D CNTERRS("ORDER NUMBER DOES NOT EXIST") Q
  1. I MESSAGE["NO 'RESULTS AVAILABLE' DATE" D CNTERRS("NO 'RESULTS AVAILABLE' DATE") Q
  1. I MESSAGE["ORDER NUMBER",MESSAGE["ORDER DATE DOES NOT EXIST" D CNTERRS("ORDER DATE DOES NOT EXIST") Q
  1. I MESSAGE["ORDER DATE'S",MESSAGE["DOES NOT EXIST" D CNTERRS("LRSN DOES NOT EXIST") Q
  1. ;
  1. D CNTERRS(MESSAGE)
  1. Q
  1. ;
  1. CNTERRS(ERRMSG) ; EP
  1. S ^TMP("BLRPCCRR",$J,"ERRCNTS",ERRMSG)=1+$G(^TMP("BLRPCCRR",$J,"ERRCNTS",ERRMSG))
  1. Q
  1. ;
  1. TESTNAME(TIEN) ; EP - Return Test Name from File 60. IFF Ref Lab AOE test, add "[ AOE ]" to end of the name
  1. NEW BLRCRL,BLRRIEN,DESCRIP
  1. ;
  1. S DESCRIP=$$GET1^DIQ(60,+TIEN,"NAME")
  1. S:$L(DESCRIP)<1 DESCRIP=" "
  1. ;
  1. S BLRCRL=+$P($G(^BLRSITE(DUZ(2),"RL")),U)
  1. Q:BLRCRL<1 DESCRIP ; No Reference Lab defined for DUZ(2), so return
  1. ;
  1. S BLRRIEN=+$O(^BLRRL("ALP",TIEN,BLRCRL,0))
  1. Q:BLRRIEN<1 DESCRIP ; No Reference Lab defined test, so return
  1. ;
  1. Q:'$D(^BLRRL(BLRCRL,1,BLRRIEN,1,0)) DESCRIP ; No comments for test
  1. ;
  1. Q DESCRIP_" [ AOE ]" ; Make test as AOE test