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