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

BEHORXF3.m

Go to the documentation of this file. 
  1. BEHORXF3 ;MSC/IND/PLS - Support for Lab Test lookup when ordering meds;13-Feb-2014 12:09;PLS
  1.  ;;1.1;BEH COMPONENTS;**009012**;Sep 18, 2007;Build 3
  1.  ;=================================================================
  1.  ; RPC: BEHORXF3 LABTESTS
  1.  ; Returns test results for lab tests associated with a pharmacy orderable item
  1.  ; Input: DFN - Patient
  1.  ;        OI  - Orderable Item
  1. LABTESTS(DATA,DFN,OI) ;EP-
  1.  N POI,TSTS,LP,STR,CNT,ARY,ARYC,SEQN
  1.  S CNT=0,ARYC=0
  1.  S POI=+$P($G(^ORD(101.43,+OI,0)),U,2)
  1.  K TSTS,DATA
  1.  D GETWP^XPAR(.TSTS,"SYS","BEHORX LAB TESTS",POI)
  1.  I $L($G(TSTS)) D
  1.  .S LP=0 F  S LP=$O(TSTS(LP)) Q:'LP  D
  1.  ..S STR=$G(TSTS(LP,0))
  1.  ..Q:STR=""
  1.  ..S SEQN=$P(STR,U,5)
  1.  ..I SEQN D
  1.  ...S ARY(SEQN,0)=STR
  1.  ..E  D
  1.  ...S ARYC=ARYC+1
  1.  ...S ARY("X"_ARYC,0)=STR
  1.  .S LP=0 F  S LP=$O(ARY(LP)) Q:LP=""  D
  1.  ..S STR=$G(ARY(LP,0))
  1.  ..Q:STR=""
  1.  ..D LABRSLT(DFN,+STR,$P(STR,U,3),+$P(STR,U,4))
  1.  E  S DATA(0)=CNT  ;No tests associated with Pharmacy Orderable Item
  1.  Q
  1.  ; Call Lab Package for test results
  1. LABRSLT(DFN,TST,DAYS,SPEC) ;EP-
  1.  N IDT,SUB
  1.  K ^TMP("LRRR",$J)
  1.  D RR^LR7OR1(DFN,,$S($G(DAYS):$$FMADD^XLFDT(DT,-DAYS),1:365),DT,,TST,,1,$G(SPEC))
  1.  I $D(^TMP("LRRR",$J,DFN,"CH")) D
  1.  .S IDT=0 F  S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'IDT  D
  1.  ..S SUB=0 F  S SUB=$O(^TMP("LRRR",$J,DFN,"CH",IDT,SUB)) Q:'SUB  D
  1.  ...D ADDRES(^TMP("LRRR",$J,DFN,"CH",IDT,SUB))
  1.  E  D
  1.  .D ADD($P($G(^LAB(60,TST,0)),U))
  1.  .D ADD("  No results available in last "_DAYS_" days.")  ; for "_$P($G(^LAB(60,TST,0)),U))
  1.  .D ADD("")
  1.  Q
  1.  ; Add result to output
  1. ADDRES(VAL) ;EP-
  1.  N TSTN,TRNG,TRES,TUNIT,TDT
  1.  S TRES=$P(VAL,U,2)
  1.  S TSTN=$P(VAL,U,10) S:TSTN="" TSTN=$P(VAL,U,15)
  1.  S TRNG=$P(VAL,U,5)
  1.  S TUNIT=$P(VAL,U,4)
  1.  S TDT=9999999-IDT
  1.  S CNT=CNT+1
  1.  D ADD(TSTN)
  1.  D ADD("  Most recent value was "_TRES_" "_TUNIT_" on "_$P($TR($$FMTE^XLFDT(TDT,"5Z"),"@"," "),":",1,2))
  1.  D ADD("    Reference Range: "_TRNG_" "_TUNIT)
  1.  D ADD("")
  1.  Q
  1.  ; Add to return array
  1. ADD(VAL) ;EP-
  1.  S CNT=CNT+1
  1.  S DATA(CNT)=VAL
  1.  Q
  1.  ; Return boolean flag indicate status of tests associated with orderable item
  1. TSTASSOC(DATA,OI) ;EP-
  1.  N POI,TSTS
  1.  S POI=+$P($G(^ORD(101.43,+OI,0)),U,2)
  1.  K TSTS
  1.  D GETWP^XPAR(.TSTS,"SYS","BEHORX LAB TESTS",POI)
  1.  S DATA=$L($G(TSTS))>0
  1.  Q
  1.  ;
  1. LTEN ;-- main entry point for BEHORX LAB TESTS
  1.  N POI
  1.  S POI=$$LOOKUP^BEHUTIL(50.7,"Pharmacy Orderable Item")
  1.  Q:'POI
  1.  D EN^VALM("BEHORX LAB TESTS")
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)="Manage Pharmacy Orderable Test Mappings"
  1.  S VALMHDR(2)="Rx Orderable: "_$P($G(^PS(50.7,+POI,0)),U)
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  D CLEAN^VALM10
  1.  D BUILDLST
  1.  Q
  1.  ; Set line into array
  1. SETARR(LINE,TEXT,IEN,DAYS,SPEC,SEQN) ;EP-
  1.  S @VALMAR@(LINE,0)=TEXT
  1.  S:$G(IEN) @VALMAR@("IDX",LINE,LINE)=""
  1.  S @VALMAR@(LINE,"POIIEN")=LINE_U_IEN
  1.  S @VALMAR@(LINE,"DATA")=LINE_U_IEN_U_DAYS_U_SPEC_U_SEQN
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K SAVE
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. BUILDLST ;EP-
  1.  N LST,LP,VAL
  1.  S VALMCNT=0
  1.  D GETWP^XPAR(.LST,"SYS","BEHORX LAB TESTS",POI)
  1.  I $L($G(LST)) D
  1.  .S LP=0 F  S LP=$O(LST(LP)) Q:'LP  D
  1.  ..S VAL=LST(LP,0)
  1.  ..D ADDITEM($P(VAL,U),$P(VAL,U,3),$P(VAL,U,4),$P(VAL,U,5))
  1.  Q
  1.  ; Add a single line item
  1. ADDITEM(TST,DAYS,SPEC,SEQ) ;EP-
  1.  N LINE
  1.  S VALMCNT=VALMCNT+1
  1.  S LINE=$$SETFLD^VALM1(VALMCNT,"","ITEM")
  1.  S LINE=$$SETFLD^VALM1($P($G(^LAB(60,TST,0)),U),LINE,"TEST")
  1.  S LINE=$$SETFLD^VALM1(DAYS,LINE,"DAYS")
  1.  S LINE=$$SETFLD^VALM1(SEQ,LINE,"SEQ")
  1.  S LINE=$$SETFLD^VALM1($P($G(^LAB(61,+SPEC,0)),U),LINE,"SPEC")
  1.  D SETARR(VALMCNT,LINE,TST,DAYS,SPEC,SEQ)
  1.  Q
  1.  ; Update an existing line item
  1. UPDITM(ITM,TST,DAYS,SPEC,SEQ) ;EP-
  1.  N LINE
  1.  S LINE=$$SETFLD^VALM1(VALMCNT,"","ITEM")
  1.  S LINE=$$SETFLD^VALM1($P($G(^LAB(60,TST,0)),U),LINE,"TEST")
  1.  S LINE=$$SETFLD^VALM1(DAYS,LINE,"DAYS")
  1.  S LINE=$$SETFLD^VALM1(SEQ,LINE,"SEQ")
  1.  S LINE=$$SETFLD^VALM1($P($G(^LAB(61,+SPEC,0)),U),LINE,"SPEC")
  1.  D SETARR(ITM,LINE,TST,DAYS,SPEC,SEQ)
  1.  Q
  1. ADDTEST ;EP-
  1.  D FULL^VALM1
  1.  N DIR,DUOUT,DIRUT,Y,IEN,TSTIEN,DAYSNUM,SPECIEN,SEQN,BEHOPOP
  1.  S BEHOPOP=0
  1.  S TSTIEN=$$GETIEN1(60,"Laboratory Test: ",-1,,"I ""BO""[$P(^(0),U,3)")
  1.  I $D(DIRUT)!$D(DUOUT)!BEHOPOP S VALMBCK="R" Q
  1.  I $$CHKDUP(TSTIEN,2) S VALMSG="Selected test is already included in mapping!",VALMBCK="R" Q
  1.  S DAYSNUM=$$DIR("NO^1:999999","Days Back (defaults to 365 if not specified): ",,.BEHOPOP)
  1. ADDTEST2 S SEQN=$$DIR("N^1:99","Sequence Number: ",,,.BEHOPOP)
  1.  I BEHOPOP S VALMBCK="R" Q
  1.  I $$CHKDUP(SEQN,5) D  G ADDTEST2
  1.  .W !,"Specified sequence number is already in use!",!
  1.  S SPECIEN=$$GETIEN1(61,"Specimen type Defaults to 'ALL'): ",-1)
  1.  I BEHOPOP<0 S VALMBCK="R" Q
  1.  S:SPECIEN<0 SPECIEN=""
  1.  D ADDITEM(TSTIEN,DAYSNUM,SPECIEN,SEQN)
  1.  D SAVELST
  1.  D INIT
  1.  Q
  1.  ;
  1. SAVELST ;EP-
  1.  N ARY,ERR,LP,VAL
  1.  S LP=0 F  S LP=$O(@VALMAR@(LP)) Q:'LP  D
  1.  .S VAL=$G(@VALMAR@(LP,"DATA"))
  1.  .S ARY(LP,0)=$P(VAL,U,2)_U_$P($G(^LAB(60,+$P(VAL,U,2),0)),U)_U_$P(VAL,U,3,5)
  1.  I $D(ARY)>1 D
  1.  .S ARY="LAB INFO"
  1.  .D DEL^XPAR("SYS","BEHORX LAB TESTS","`"_POI,.ERR)
  1.  .D EN^XPAR("SYS","BEHORX LAB TESTS","`"_POI,.ARY,.ERR)
  1.  .S VALMSG="Mappings have been saved."
  1.  E  D UNMAP
  1.  ;D RE^VALM4
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. DELITEM ;EP-
  1.  N DA,DUOUT,Y,VAL,ITM,DTOUT,DIRUT,DIE,DR,LST
  1.  S LST=""
  1.  S DIR("A")="Select Items",DIR(0)="LO^1:"_VALMCNT D ^DIR
  1.  I $D(DUOUT) S VALMBCK="R" Q
  1.  I +Y D FULL^VALM1 S LST=Y
  1.  F ITM=1:1:$L(LST,",") Q:$P(LST,",",ITM)']""  S VAL=$P(LST,",",ITM) D
  1.  .K @VALMAR@(VAL)
  1.  .K @VALMAR@("IDX",VAL)
  1.  D SAVELST
  1.  D INIT
  1.  Q
  1.  ;
  1. UNMAP ;EP-
  1.  N ARY
  1.  S ARY="LAB INFO"
  1.  D DEL^XPAR("SYS","BEHORX LAB TESTS","`"_POI,.ERR)
  1.  D INIT
  1.  S VALMBCK="R"
  1.  Q
  1.  ; Change POI
  1. CHGPOI ;EP-
  1.  S POI=$$LOOKUP^BEHUTIL(50.7,"Pharmacy Orderable Item")
  1.  D INIT
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. EDTITEM ;EP-
  1.  N DA,DUOUT,Y,VAL,ITM,DTOUT,DIRUT,DIE,DR,LST
  1.  S LST=""
  1.  S DIR("A")="Select Items",DIR(0)="LO^1:"_VALMCNT D ^DIR
  1.  I $D(DUOUT) S VALMBCK="R" Q
  1.  I +Y D FULL^VALM1 S LST=Y
  1.  F ITM=1:1:$L(LST,",") Q:$P(LST,",",ITM)']""  S VAL=$P(LST,",",ITM) D
  1.  .D EDTITEM1(VAL)
  1.  D SAVELST
  1.  D INIT
  1.  S VALMBCK="R"
  1.  Q
  1.  ;EP-
  1. EDTITEM1(IDX) ;
  1.  N VAL,TSTIEN,SPECIEN,DAYS,SEQN,SEQNT,BEHOPOP
  1.  S VAL=@VALMAR@(IDX,"DATA")
  1.  S TSTIEN=$P(VAL,U,2)
  1.  S DAYS=$P(VAL,U,3)
  1.  S SPECIEN=$P(VAL,U,4)
  1.  S SEQN=$P(VAL,U,5)
  1.  S BEHOPOP=0
  1.  ;S TSTIEN=$$GETIEN1(60,"Laboratory Test: ",-1,,"I ""BO""[$P(^(0),U,3)",$P($G(^LAB(60,+TSTIEN,0)),U))
  1.  ;Q:BEHOPOP
  1.  S TSTIEN=$$DIR("PO^60:EM","Laboratory Test: ",$P($G(^LAB(60,+TSTIEN,0)),U),,.BEHOPOP,"I ""BO""[$P(^(0),U,3)")
  1.  I BEHOPOP D  Q:BEHOPOP
  1.  .I $P(BEHOPOP,U,2) D
  1.  ..K @VALMAR@(IDX)
  1.  ..K @VALMAR@("IDX",IDX)
  1.  E  S TSTIEN=+TSTIEN
  1.  I $$CHKDUP(TSTIEN,2,IDX) S VALMSG="Selected test is already included in mapping!",VALMBCK="R" Q
  1.  S DAYSNUM=$$DIR("NO^1:999999","Days Back (defaults to 365 if not specified): ",DAYS,,.BEHOPOP)
  1.  I BEHOPOP D  Q:BEHOPOP
  1.  .I $P(BEHOPOP,U,2) S DAYSNUM="",BEHOPOP=0
  1. EDTITEM2 S SEQNT=$$DIR("N^1:99","Sequence Number: ",SEQN,,,.BEHOPOP)
  1.  ;I BEHOPOP S VALMBCK="R" Q
  1.  Q:BEHOPOP
  1.  I $$CHKDUP(SEQNT,5,IDX) D  G EDTITEM2
  1.  .W !,"Specified sequence number is already in use!",!
  1.  S SEQN=SEQNT
  1.  ;S SPECIEN=$$GETIEN1(61,"Specimen type (Defaults to 'ALL'): ",-1,,,$P($G(^LAB(61,+SPECIEN,0)),U))
  1.  S SPECIEN=$$DIR("PO^61","Specimen type (Defaults to 'ALL'): ",$P($G(^LAB(61,+SPECIEN,0)),U),,.BEHOPOP)
  1.  I BEHOPOP<0 D  Q:BEHOPOP
  1.  .I $P(BEHOPOP,U,2) S SPECIEN="",BEHOPOP=0
  1.  S:SPECIEN<0 SPECIEN=""
  1.  D UPDITM(IDX,TSTIEN,DAYSNUM,+SPECIEN,SEQN)
  1.  Q
  1.  ; Return boolean flag indicating presence of VALue at POSition
  1. CHKDUP(VAL,POS,EDT) ;EP-
  1.  N LP
  1.  S EDT=$G(EDT,0)
  1.  S RES=0
  1.  S LP=0 F  S LP=$O(@VALMAR@(LP)) Q:'LP!RES  D
  1.  .Q:LP=EDT
  1.  .S STR=@VALMAR@(LP,"DATA")
  1.  .S:$P(STR,U,POS)=VAL RES=1
  1.  Q RES
  1.  ;FileMan Utilities
  1.  ; Paramerized DIR call
  1. DIR(BEHODTP,BEHOPMT,BEHODFL,BEHOHLP,BEHOPOP,BEHOSCN) ; EP
  1.  N DIR,DTOUT,DUOUT,Y
  1.  S DIR(0)=BEHODTP,DIR("B")=$G(BEHODFL)
  1.  I '$G(BEHOPMT) M DIR("A")=BEHOPMT
  1.  E  D GETTEXT(BEHOPMT,$NA(DIR("A")))
  1.  I '$G(BEHOHLP) M DIR("?")=BEHOHLP
  1.  E  D GETTEXT(BEHOHLP,$NA(DIR("?")))
  1.  S:$L($G(BEHOSCN)) DIR("S")=BEHOSCN
  1.  D ^DIR
  1.  I $D(DUOUT)!$D(DTOUT)!(X="@") S BEHOPOP=1,$P(BEHOPOP,U,2)=X="@"
  1.  Q Y
  1.  ; Prompt for entry from file
  1.  ; BEHOFILE = File #
  1.  ; BEHOPMPT = Prompt
  1.  ; BEHODFLD = Field whose value is to be used for default value
  1.  ;          Set to -1 for no default value
  1.  ; D - x-ref (C^D)
  1.  ; BEHOSCRN = DIC("S") SCREEN LOGIC
  1.  ; BEHODFLT = Default value set in DIC("B") - not used if BEHODFLD is >0
  1. GETIEN1(BEHOFILE,BEHOPMPT,BEHODFLD,D,BEHOSCRN,BEHODFLT) ; EP
  1.  N DIC,BEHOD,Y
  1.  S D=$G(D,"B")
  1.  S:'$L(D) D="B"
  1.  S BEHODFLD=$G(BEHODFLD,.01)
  1.  S BEHOD=""
  1.  S DIC("S")=$G(BEHOSCRN)
  1.  S:BEHODFLD>0 BEHOD=$$GET1^DIQ(BEHOFILE,$$FIND1^DIC(BEHOFILE,,," ",.D,DIC("S")),BEHODFLD)
  1.  I BEHODFLD<0,$L($G(BEHODFLT)) S BEHOD=BEHODFLT
  1.  S DIC=BEHOFILE,DIC(0)="AE",DIC("A")=$G(BEHOPMPT),DIC("B")=BEHOD
  1.  I $L(D,U)>1,DIC(0)'["M" S DIC(0)=DIC(0)_"M"
  1.  D MIX^DIC1
  1.  I $D(DUOUT)!($D(DTOUT)) S BEHOPOP=-1
  1.  E  I Y'>0 S BEHOPOP=1,$P(BEHOPOP,U,2)=X="@"
  1.  ;I Y'>0 D
  1.  ;.S BEHOPOP=1,$P(BEHOPOP,U,2)=X="@"
  1.  ;E  I $D(DUOUT)!($D(DTOUT)) S BEHOPOP=-1
  1.  ;S:Y'>0 BEHOPOP=1,$P(BEHOPOP,U,2)=X="@"
  1.  Q +Y
  1.  ; Load dialog text into array
  1.  ; BEHODG = Dialog index^optional parameters
  1.  ; BEHOAR = Array to receive text
  1. GETTEXT(BEHODG,BEHOAR) ;
  1.  N BEHOPM
  1.  K @BEHOAR
  1.  F X=2:1:$L(BEHODG,U) S BEHOPM(X-1)=$P(BEHODG,U,X)
  1.  S BEHODG=$S(BEHODG<0:-BEHODG,1:+BEHODG)
  1.  D BLD^DIALOG(BEHODG/1000+59000,.BEHOPM,,BEHOAR)
  1.  Q