- ORWDLR32 ; SLC/KCM/REV/JDL - Lab Calls; 6/28/2002
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250,243,315**;Dec 17, 1997;Build 20
- ;
- ; DBIA 91 ^LAB(60
- ; DBIA 2263 GETLST^XPAR ^TMP($J,"WC")
- ; DBIA 2388 ^LAB(61
- ; DBIA 2389 ^LAB(62
- ; DBIA 2390 ^LAB(62.05
- ; DBIA 2428 DEFURG^LR7OR3
- ; DBIA 2428 TEST^LR7OR3
- ; DBIA 2429 ON^LR7OV4
- ;
- DEF(LST,ALOC,ADIV) ; procedure
- ; For Event Delay Order
- ; ALOC: Delay Event's default location
- ; ADIV: Delay Event's default division
- ; get dialog definition specific to lab
- S ILST=0
- S LST($$NXT)="~ShortList" D SHORT
- S LST($$NXT)="~Lab Collection Times" D LCOLLTM
- S LST($$NXT)="~Ward Collection Times" D WCOLLTM
- S LST($$NXT)="~Send Patient Times" D SENDTM
- S LST($$NXT)="~Collection Types" D COLLTYP
- S LST($$NXT)="~Default Urgency" D URGENCY
- S LST($$NXT)="~Schedules" D SCHED
- S LST($$NXT)="~Common" D COMMON
- Q
- SHORT ; from DEF, get short list of lab quick orders
- N I,ORTMP,ORDG,A
- S I=$O(^ORD(100.98,"B","LAB",0)) ; get IEN of parent lab
- D DG^ORCHANG1(I,"BILD",.ORDG) ; find members groups for parent lab
- S I=0
- F S I=$O(ORDG(I)) Q:'I D ; loop through list of members groups
- . I $E($P($G(^ORD(100.98,I,0)),"^",3),1,2)="VB" Q
- . D GETQLST^ORWDXQ(.ORTMP,I,"Q") ;get quick order of each members groups
- . S A=0 F S A=$O(ORTMP(A)) Q:'A D ; loop through returned quick orders and
- . . S LST($$NXT)="i"_ORTMP(A) ; move quick orders to display list
- . K ORTMP ; clean up for next members groups of quick orders
- Q
- LCOLLTM ; get collection times
- N TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT
- S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H,TDAY("TX")="T"
- M TMRW=TDAY D INCDATE(.TMRW)
- I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D
- . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q")
- . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q")
- . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q")
- . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q")
- . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q")
- . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q")
- . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q")
- . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q")
- . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6
- . . D INCDATE(.TDAY) S CNT=CNT+1
- . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6
- . . D INCDATE(.TMRW) S CNT=CNT+1
- I $G(ADIV) D GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q")
- E D GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
- ;S DUZ(2)=TMPDIV
- S LST($$NXT)="iLNEXT^Next scheduled lab collection"
- S ICTM=0 F S ICTM=$O(ORCTM(ICTM)) Q:'ICTM D
- . I $P(ORCTM(ICTM),U)>$P($H,",",2) D
- . . S TXDT=TDAY("TX")
- . . I +TDAY("H")=+$H S DAY="Today"
- . . I TDAY("H")-$H=1 S DAY="Tomorrow"
- . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW"))
- . E D
- . . S TXDT=TMRW("TX")
- . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow")
- . S AMPM=$S($P(ORCTM(ICTM),U,2)>1159:"PM",1:"AM")
- . S TXDT=TXDT_"@"_$P(ORCTM(ICTM),"^",2)
- . S TIME=$P(ORCTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
- . S LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")"
- . S ^TMP($J,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect" ;DBIA 2263
- ; D NOW^%DTC
- ;S LST($$NXT)="iWNOW^Now (Collect on ward)"
- S LST($$NXT)="iLO^Future"
- Q
- WCOLLTM ; get Ward Collect times
- S I=""
- F S I=$O(^TMP($J,"WC",I)) Q:I="" D
- . S LST($$NXT)=^TMP($J,"WC",I)
- S LST($$NXT)="iWNOW^Now (Collect on ward)"
- ;S LST($$NXT)="iWO^Other"
- K ^TMP($J,"WC")
- Q
- SENDTM ; get send patient times
- ;N X,X1,X2
- S LST($$NXT)="iLT^Today"
- ;S X1=DT,X2=1 D C^%DTC
- S LST($$NXT)="iLT+1^Tomorrow"
- ;S LST($$NXT)="iLO^Other"
- Q
- COLLTYP ; Collection Types in effect for this division
- N Y S Y=""
- S LST($$NXT)="iLC^Lab Collect"
- S LST($$NXT)="iWC^Ward Collect"
- S LST($$NXT)="iSP^Send Patient to Lab"
- I +$$ON^LR7OV4(DUZ(2)) S LST($$NXT)="iI^Immediate Collect"
- S:$G(ALOC) Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK")
- I $L(Y) S LST($$NXT)="d"_Y
- Q
- INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE
- N X,X1,X2,%H
- S X1=ADATE,X2=1 D C^%DTC S ADATE=X
- S ADATE("H")=ADATE("H")+1
- S ADATE("DOW")=ADATE("H")#7
- S ADATE("TX")="T+"_($P(ADATE("TX"),"+",2)+1)
- Q
- DOWNAME(DOW) ; function
- ; Returns Day of Week name (DOW should be $H#7)
- I DOW=0 Q "Thursday"
- I DOW=1 Q "Friday"
- I DOW=2 Q "Saturday"
- I DOW=3 Q "Sunday"
- I DOW=4 Q "Monday"
- I DOW=5 Q "Tuesday"
- I DOW=6 Q "Wednesday"
- Q ""
- URGENCY ; return default urgency for lab
- N URG
- S URG=$$DEFURG^LR7OR3
- S LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1)
- S LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1)
- Q
- SCHED ; return list of schedules available for lab tests
- N X,X0,IEN,TYPE,FREQ
- K ^TMP($J,"ORWDLR32 APLR")
- D AP^PSS51P1("LR",,,,"ORWDLR32 APLR")
- S X="" F S X=$O(^TMP($J,"ORWDLR32 APLR","APLR",X)) Q:X="" D
- .S IEN=$O(^TMP($J,"ORWDLR32 APLR","APLR",X,"")) I IEN'>0 Q
- .S TYPE=$P($G(^TMP($J,"ORWDLR32 APLR",IEN,5)),U)
- .S FREQ=+$G(^TMP($J,"ORWDLR32 APLR",IEN,2))
- .I ((TYPE="C")!(TYPE="D")),FREQ=0 Q
- .S LST($$NXT)="i"_IEN_U_X_U_TYPE_U_FREQ
- .I X="ONE TIME" S LST($$NXT)="d"_IEN_U_X
- K ^TMP($J,"ORWDLR32 APLR")
- Q
- COMMON ; return list of commonly ordered lab tests
- N ORLST,IEN,I
- D GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT") ;DBIA 2263
- S I=0 F S I=$O(ORLST(I)) Q:'I D
- . S IEN=$P(ORLST(I),U,2)
- . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1)
- Q
- LOAD(LST,TESTID) ; procedure
- ; Return sample, specimen, & urgency info about a lab test
- N I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM
- S ILST=0,X=$P(^ORD(101.43,TESTID,0),"^"),ORLABID=$P(^(0),U,2)
- S LST($$NXT)="~Test Name"
- S LST($$NXT)="d"_X
- S LST($$NXT)="~Item ID"
- S LST($$NXT)="d"_+ORLABID
- S X1=$S($P($P(^ORD(101.43,TESTID,0),U,2),";",2)="99VBC":$O(^LAB(60,"B",$P(^ORD(101.43,TESTID,0),"^")_" - LAB",0)),1:$P($P(^ORD(101.43,TESTID,0),U,2),";",1)) Q:'X1
- S X4=$P($G(^LAB(60,X1,0)),U,4)
- S LST(ILST)=LST(ILST)_U_X4
- I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage"
- S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0)
- S TESTID=+$P(^ORD(101.43,TESTID,0),U,2)
- D TEST^LR7OR3(X1,.ORY)
- S PARAM="" F S PARAM=$O(ORY(PARAM)) Q:PARAM="" D
- . S LST($$NXT)="~"_PARAM
- . I PARAM="ReqCom" D
- . . S LST($$NXT)="d"_$G(ORY("ReqCom")) Q
- . I PARAM="Default CollSamp" D
- . . S LST($$NXT)="d"_$G(ORY("Default CollSamp")) Q
- . I PARAM="Unique CollSamp" D
- . . S LST($$NXT)="d"_$G(ORY("Unique CollSamp")) Q
- . I PARAM="Default Urgency" D
- . . S LST($$NXT)="d"_$G(ORY("Default Urgency")) Q
- . I PARAM="Lab CollSamp" D
- . . S LST($$NXT)="d"_$G(ORY("Lab CollSamp")) Q
- . I $D(ORY(PARAM))>1 S I=0 F S I=$O(ORY(PARAM,I)) Q:'I D
- . . I PARAM="Specimens" S LST($$NXT)="i"_ORY(PARAM,I) Q
- . . I PARAM="Urgencies" S LST($$NXT)="i"_ORY(PARAM,I) Q
- . . I PARAM="GenWardInstructions" S LST($$NXT)="t"_ORY(PARAM,I,0) Q
- . . S LST($$NXT)="i"_I_U_ORY(PARAM,I)
- . . I PARAM="CollSamp" D
- . . . I $G(ORY("Lab CollSamp")) S $P(LST(ILST),U,8)=1
- . . . S X=+$P(ORY(PARAM,I),U,3)
- . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1)
- . . I $D(ORY(PARAM,I,"WP")) S J=0 F S J=$O(ORY(PARAM,I,"WP",J)) Q:'J D
- . . . S LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0)
- Q
- ALLSAMP(LST) ; procedure
- ; returns all collection samples
- ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
- N SMP,SPC,ILST,IEN,X,X0,A,%,INC
- S ILST=0,LST($$NXT)="~CollSamp"
- S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D
- . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D
- . . S INC=1 I $D(^LAB(62,IEN,64.91)) D I 'INC Q
- . . . S A=^LAB(62,IEN,64.91)
- . . . S B=$P(A,"^") D NOW^%DTC I B]"",B'>$P(%,".") S INC=0 Q
- . . S X0=^LAB(62,IEN,0)
- . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
- . . I $P(X0,U,2) D
- . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
- . . . S SPC($P(X,U,4))=$P(X,U,10)
- . . S LST($$NXT)=X
- S LST($$NXT)="~Specimens"
- S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC)
- Q
- ONESAMP(LST,IEN) ;Return data for one colelction sample
- ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
- N SPC,ILST,X,X0
- Q:+$G(IEN)=0
- S ILST=0,LST($$NXT)="~CollSamp"
- S X0=^LAB(62,IEN,0)
- S X="i1"_U_IEN_U_$P(X0,U,1)_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7)
- I $P(X0,U,2) D
- . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1)
- . S SPC($P(X,U,4))=$P(X,U,10)
- S LST($$NXT)=X
- S LST($$NXT)="~Specimens"
- S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC)
- Q
- ONESPEC(LST,IEN) ;return one specimen
- Q:(+$G(IEN)=0)!('$D(^LAB(61,IEN,0)))
- S LST=IEN_U_$P(^LAB(61,IEN,0),U,1)
- Q
- ABBSPEC(LST) ; procedure
- ; returns specimens with abbreviation (uses 'E' xref)
- N X,IEN,ILST S ILST=0
- S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D
- . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1)
- Q
- NXT() ; called by TESTINFO, increments ILST
- S ILST=ILST+1
- Q ILST
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDLR32 9076 printed Jan 18, 2025@03:36:42 Page 2
- ORWDLR32 ; SLC/KCM/REV/JDL - Lab Calls; 6/28/2002
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,141,215,250,243,315**;Dec 17, 1997;Build 20
- +2 ;
- +3 ; DBIA 91 ^LAB(60
- +4 ; DBIA 2263 GETLST^XPAR ^TMP($J,"WC")
- +5 ; DBIA 2388 ^LAB(61
- +6 ; DBIA 2389 ^LAB(62
- +7 ; DBIA 2390 ^LAB(62.05
- +8 ; DBIA 2428 DEFURG^LR7OR3
- +9 ; DBIA 2428 TEST^LR7OR3
- +10 ; DBIA 2429 ON^LR7OV4
- +11 ;
- DEF(LST,ALOC,ADIV) ; procedure
- +1 ; For Event Delay Order
- +2 ; ALOC: Delay Event's default location
- +3 ; ADIV: Delay Event's default division
- +4 ; get dialog definition specific to lab
- +5 SET ILST=0
- +6 SET LST($$NXT)="~ShortList"
- DO SHORT
- +7 SET LST($$NXT)="~Lab Collection Times"
- DO LCOLLTM
- +8 SET LST($$NXT)="~Ward Collection Times"
- DO WCOLLTM
- +9 SET LST($$NXT)="~Send Patient Times"
- DO SENDTM
- +10 SET LST($$NXT)="~Collection Types"
- DO COLLTYP
- +11 SET LST($$NXT)="~Default Urgency"
- DO URGENCY
- +12 SET LST($$NXT)="~Schedules"
- DO SCHED
- +13 SET LST($$NXT)="~Common"
- DO COMMON
- +14 QUIT
- SHORT ; from DEF, get short list of lab quick orders
- +1 NEW I,ORTMP,ORDG,A
- +2 ; get IEN of parent lab
- SET I=$ORDER(^ORD(100.98,"B","LAB",0))
- +3 ; find members groups for parent lab
- DO DG^ORCHANG1(I,"BILD",.ORDG)
- +4 SET I=0
- +5 ; loop through list of members groups
- FOR
- SET I=$ORDER(ORDG(I))
- if 'I
- QUIT
- Begin DoDot:1
- +6 IF $EXTRACT($PIECE($GET(^ORD(100.98,I,0)),"^",3),1,2)="VB"
- QUIT
- +7 ;get quick order of each members groups
- DO GETQLST^ORWDXQ(.ORTMP,I,"Q")
- +8 ; loop through returned quick orders and
- SET A=0
- FOR
- SET A=$ORDER(ORTMP(A))
- if 'A
- QUIT
- Begin DoDot:2
- +9 ; move quick orders to display list
- SET LST($$NXT)="i"_ORTMP(A)
- End DoDot:2
- +10 ; clean up for next members groups of quick orders
- KILL ORTMP
- End DoDot:1
- +11 QUIT
- LCOLLTM ; get collection times
- +1 NEW TDAY,TMRW,IGNOR,CNT,ICTM,ORCTM,DOW,AMPM,DAY,TIME,TXDT
- +2 SET TDAY=DT
- SET TDAY("DOW")=$HOROLOG#7
- SET TDAY("H")=$HOROLOG
- SET TDAY("TX")="T"
- +3 MERGE TMRW=TDAY
- DO INCDATE(.TMRW)
- +4 IF $GET(ALOC)
- IF '$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q")
- Begin DoDot:1
- +5 SET IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q")
- +6 SET DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q")
- +7 SET DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q")
- +8 SET DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q")
- +9 SET DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q")
- +10 SET DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q")
- +11 SET DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q")
- +12 SET DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q")
- +13 SET CNT=0
- FOR
- if (DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$DATA(^HOLIDAY(TDAY,0))))
- QUIT
- Begin DoDot:2
- +14 DO INCDATE(.TDAY)
- SET CNT=CNT+1
- End DoDot:2
- if CNT>6
- QUIT
- +15 SET CNT=0
- FOR
- if (DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$DATA(^HOLIDAY(TMRW,0))))
- QUIT
- Begin DoDot:2
- +16 DO INCDATE(.TMRW)
- SET CNT=CNT+1
- End DoDot:2
- if CNT>6
- QUIT
- End DoDot:1
- +17 IF $GET(ADIV)
- DO GETLST^XPAR(.ORCTM,ADIV_";DIC(4,^SYS","LR PHLEBOTOMY COLLECTION","Q")
- +18 IF '$TEST
- DO GETLST^XPAR(.ORCTM,"ALL","LR PHLEBOTOMY COLLECTION","Q")
- +19 ;S DUZ(2)=TMPDIV
- +20 SET LST($$NXT)="iLNEXT^Next scheduled lab collection"
- +21 SET ICTM=0
- FOR
- SET ICTM=$ORDER(ORCTM(ICTM))
- if 'ICTM
- QUIT
- Begin DoDot:1
- +22 IF $PIECE(ORCTM(ICTM),U)>$PIECE($HOROLOG,",",2)
- Begin DoDot:2
- +23 SET TXDT=TDAY("TX")
- +24 IF +TDAY("H")=+$HOROLOG
- SET DAY="Today"
- +25 IF TDAY("H")-$HOROLOG=1
- SET DAY="Tomorrow"
- +26 IF TDAY("H")-$HOROLOG>1
- SET DAY=$$DOWNAME(TDAY("DOW"))
- End DoDot:2
- +27 IF '$TEST
- Begin DoDot:2
- +28 SET TXDT=TMRW("TX")
- +29 SET DAY=$SELECT(TMRW("H")-$HOROLOG>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow")
- End DoDot:2
- +30 SET AMPM=$SELECT($PIECE(ORCTM(ICTM),U,2)>1159:"PM",1:"AM")
- +31 SET TXDT=TXDT_"@"_$PIECE(ORCTM(ICTM),"^",2)
- +32 SET TIME=$PIECE(ORCTM(ICTM),U,2)
- SET TIME=$EXTRACT(TIME,1,2)_":"_$EXTRACT(TIME,3,4)
- +33 SET LST($$NXT)="iL"_TXDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")"
- +34 ;DBIA 2263
- SET ^TMP($JOB,"WC",ILST)="iW"_TXDT_U_TIME_" "_AMPM_" ("_DAY_") Ward collect"
- End DoDot:1
- +35 ; D NOW^%DTC
- +36 ;S LST($$NXT)="iWNOW^Now (Collect on ward)"
- +37 SET LST($$NXT)="iLO^Future"
- +38 QUIT
- WCOLLTM ; get Ward Collect times
- +1 SET I=""
- +2 FOR
- SET I=$ORDER(^TMP($JOB,"WC",I))
- if I=""
- QUIT
- Begin DoDot:1
- +3 SET LST($$NXT)=^TMP($JOB,"WC",I)
- End DoDot:1
- +4 SET LST($$NXT)="iWNOW^Now (Collect on ward)"
- +5 ;S LST($$NXT)="iWO^Other"
- +6 KILL ^TMP($JOB,"WC")
- +7 QUIT
- SENDTM ; get send patient times
- +1 ;N X,X1,X2
- +2 SET LST($$NXT)="iLT^Today"
- +3 ;S X1=DT,X2=1 D C^%DTC
- +4 SET LST($$NXT)="iLT+1^Tomorrow"
- +5 ;S LST($$NXT)="iLO^Other"
- +6 QUIT
- COLLTYP ; Collection Types in effect for this division
- +1 NEW Y
- SET Y=""
- +2 SET LST($$NXT)="iLC^Lab Collect"
- +3 SET LST($$NXT)="iWC^Ward Collect"
- +4 SET LST($$NXT)="iSP^Send Patient to Lab"
- +5 IF +$$ON^LR7OV4(DUZ(2))
- SET LST($$NXT)="iI^Immediate Collect"
- +6 if $GET(ALOC)
- SET Y=$$GET^XPAR("ALL^"_ALOC_";SC(","LR DEFAULT TYPE QUICK")
- +7 IF $LENGTH(Y)
- SET LST($$NXT)="d"_Y
- +8 QUIT
- INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE
- +1 NEW X,X1,X2,%H
- +2 SET X1=ADATE
- SET X2=1
- DO C^%DTC
- SET ADATE=X
- +3 SET ADATE("H")=ADATE("H")+1
- +4 SET ADATE("DOW")=ADATE("H")#7
- +5 SET ADATE("TX")="T+"_($PIECE(ADATE("TX"),"+",2)+1)
- +6 QUIT
- DOWNAME(DOW) ; function
- +1 ; Returns Day of Week name (DOW should be $H#7)
- +2 IF DOW=0
- QUIT "Thursday"
- +3 IF DOW=1
- QUIT "Friday"
- +4 IF DOW=2
- QUIT "Saturday"
- +5 IF DOW=3
- QUIT "Sunday"
- +6 IF DOW=4
- QUIT "Monday"
- +7 IF DOW=5
- QUIT "Tuesday"
- +8 IF DOW=6
- QUIT "Wednesday"
- +9 QUIT ""
- URGENCY ; return default urgency for lab
- +1 NEW URG
- +2 SET URG=$$DEFURG^LR7OR3
- +3 SET LST($$NXT)="i"_URG_U_$P(^LAB(62.05,URG,0),U,1)
- +4 SET LST($$NXT)="d"_URG_U_$P(^LAB(62.05,URG,0),U,1)
- +5 QUIT
- SCHED ; return list of schedules available for lab tests
- +1 NEW X,X0,IEN,TYPE,FREQ
- +2 KILL ^TMP($JOB,"ORWDLR32 APLR")
- +3 DO AP^PSS51P1("LR",,,,"ORWDLR32 APLR")
- +4 SET X=""
- FOR
- SET X=$ORDER(^TMP($JOB,"ORWDLR32 APLR","APLR",X))
- if X=""
- QUIT
- Begin DoDot:1
- +5 SET IEN=$ORDER(^TMP($JOB,"ORWDLR32 APLR","APLR",X,""))
- IF IEN'>0
- QUIT
- +6 SET TYPE=$PIECE($GET(^TMP($JOB,"ORWDLR32 APLR",IEN,5)),U)
- +7 SET FREQ=+$GET(^TMP($JOB,"ORWDLR32 APLR",IEN,2))
- +8 IF ((TYPE="C")!(TYPE="D"))
- IF FREQ=0
- QUIT
- +9 SET LST($$NXT)="i"_IEN_U_X_U_TYPE_U_FREQ
- +10 IF X="ONE TIME"
- SET LST($$NXT)="d"_IEN_U_X
- End DoDot:1
- +11 KILL ^TMP($JOB,"ORWDLR32 APLR")
- +12 QUIT
- COMMON ; return list of commonly ordered lab tests
- +1 NEW ORLST,IEN,I
- +2 ;DBIA 2263
- DO GETLST^XPAR(.ORLST,"ALL","ORWD COMMON LAB INPT")
- +3 SET I=0
- FOR
- SET I=$ORDER(ORLST(I))
- if 'I
- QUIT
- Begin DoDot:1
- +4 SET IEN=$PIECE(ORLST(I),U,2)
- +5 SET LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1)
- End DoDot:1
- +6 QUIT
- LOAD(LST,TESTID) ; procedure
- +1 ; Return sample, specimen, & urgency info about a lab test
- +2 NEW I,J,X,X1,X4,ORY,ORLABID,ILST,PARAM
- +3 SET ILST=0
- SET X=$PIECE(^ORD(101.43,TESTID,0),"^")
- SET ORLABID=$PIECE(^(0),U,2)
- +4 SET LST($$NXT)="~Test Name"
- +5 SET LST($$NXT)="d"_X
- +6 SET LST($$NXT)="~Item ID"
- +7 SET LST($$NXT)="d"_+ORLABID
- +8 SET X1=$SELECT($PIECE($PIECE(^ORD(101.43,TESTID,0),U,2),";",2)="99VBC":$ORDER(^LAB(60,"B",$PIECE(^ORD(101.43,TESTID,0),"^")_" - LAB",0)),1:$PIECE($PIECE(^ORD(101.43,TESTID,0),U,2),";",1))
- if 'X1
- QUIT
- +9 SET X4=$PIECE($GET(^LAB(60,X1,0)),U,4)
- +10 SET LST(ILST)=LST(ILST)_U_X4
- +11 IF $DATA(^ORD(101.43,TESTID,8))>1
- SET LST($$NXT)="~OIMessage"
- +12 SET I=0
- FOR
- SET I=$ORDER(^ORD(101.43,TESTID,8,I))
- if 'I
- QUIT
- SET LST($$NXT)="t"_^(I,0)
- +13 SET TESTID=+$PIECE(^ORD(101.43,TESTID,0),U,2)
- +14 DO TEST^LR7OR3(X1,.ORY)
- +15 SET PARAM=""
- FOR
- SET PARAM=$ORDER(ORY(PARAM))
- if PARAM=""
- QUIT
- Begin DoDot:1
- +16 SET LST($$NXT)="~"_PARAM
- +17 IF PARAM="ReqCom"
- Begin DoDot:2
- +18 SET LST($$NXT)="d"_$G(ORY("ReqCom"))
- QUIT
- End DoDot:2
- +19 IF PARAM="Default CollSamp"
- Begin DoDot:2
- +20 SET LST($$NXT)="d"_$G(ORY("Default CollSamp"))
- QUIT
- End DoDot:2
- +21 IF PARAM="Unique CollSamp"
- Begin DoDot:2
- +22 SET LST($$NXT)="d"_$G(ORY("Unique CollSamp"))
- QUIT
- End DoDot:2
- +23 IF PARAM="Default Urgency"
- Begin DoDot:2
- +24 SET LST($$NXT)="d"_$G(ORY("Default Urgency"))
- QUIT
- End DoDot:2
- +25 IF PARAM="Lab CollSamp"
- Begin DoDot:2
- +26 SET LST($$NXT)="d"_$G(ORY("Lab CollSamp"))
- QUIT
- End DoDot:2
- +27 IF $DATA(ORY(PARAM))>1
- SET I=0
- FOR
- SET I=$ORDER(ORY(PARAM,I))
- if 'I
- QUIT
- Begin DoDot:2
- +28 IF PARAM="Specimens"
- SET LST($$NXT)="i"_ORY(PARAM,I)
- QUIT
- +29 IF PARAM="Urgencies"
- SET LST($$NXT)="i"_ORY(PARAM,I)
- QUIT
- +30 IF PARAM="GenWardInstructions"
- SET LST($$NXT)="t"_ORY(PARAM,I,0)
- QUIT
- +31 SET LST($$NXT)="i"_I_U_ORY(PARAM,I)
- +32 IF PARAM="CollSamp"
- Begin DoDot:3
- +33 IF $GET(ORY("Lab CollSamp"))
- SET $PIECE(LST(ILST),U,8)=1
- +34 SET X=+$PIECE(ORY(PARAM,I),U,3)
- +35 IF X
- SET $PIECE(LST(ILST),U,10)=$PIECE($GET(^LAB(61,X,0)),U,1)
- End DoDot:3
- +36 IF $DATA(ORY(PARAM,I,"WP"))
- SET J=0
- FOR
- SET J=$ORDER(ORY(PARAM,I,"WP",J))
- if 'J
- QUIT
- Begin DoDot:3
- +37 SET LST($$NXT)="t"_ORY(PARAM,I,"WP",J,0)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +38 QUIT
- ALLSAMP(LST) ; procedure
- +1 ; returns all collection samples
- +2 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
- +3 NEW SMP,SPC,ILST,IEN,X,X0,A,%,INC
- +4 SET ILST=0
- SET LST($$NXT)="~CollSamp"
- +5 SET SMP=""
- FOR
- SET SMP=$ORDER(^LAB(62,"B",SMP))
- if SMP=""
- QUIT
- Begin DoDot:1
- +6 SET IEN=0
- FOR
- SET IEN=$ORDER(^LAB(62,"B",SMP,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +7 SET INC=1
- IF $DATA(^LAB(62,IEN,64.91))
- Begin DoDot:3
- +8 SET A=^LAB(62,IEN,64.91)
- +9 SET B=$PIECE(A,"^")
- DO NOW^%DTC
- IF B]""
- IF B'>$PIECE(%,".")
- SET INC=0
- QUIT
- End DoDot:3
- IF 'INC
- QUIT
- +10 SET X0=^LAB(62,IEN,0)
- +11 SET X="i"_U_IEN_U_SMP_U_$PIECE(X0,U,2)_U_$PIECE(X0,U,3)_U_U_U_$PIECE(X0,U,7)
- +12 IF $PIECE(X0,U,2)
- Begin DoDot:3
- +13 SET $PIECE(X,U,10)=$PIECE(^LAB(61,+$PIECE(X0,U,2),0),U,1)
- +14 SET SPC($PIECE(X,U,4))=$PIECE(X,U,10)
- End DoDot:3
- +15 SET LST($$NXT)=X
- End DoDot:2
- End DoDot:1
- +16 SET LST($$NXT)="~Specimens"
- +17 SET SPC=0
- FOR
- SET SPC=$ORDER(SPC(SPC))
- if 'SPC
- QUIT
- SET LST($$NXT)=SPC_U_SPC(SPC)
- +18 QUIT
- ONESAMP(LST,IEN) ;Return data for one colelction sample
- +1 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
- +2 NEW SPC,ILST,X,X0
- +3 if +$GET(IEN)=0
- QUIT
- +4 SET ILST=0
- SET LST($$NXT)="~CollSamp"
- +5 SET X0=^LAB(62,IEN,0)
- +6 SET X="i1"_U_IEN_U_$PIECE(X0,U,1)_U_$PIECE(X0,U,2)_U_$PIECE(X0,U,3)_U_U_U_$PIECE(X0,U,7)
- +7 IF $PIECE(X0,U,2)
- Begin DoDot:1
- +8 SET $PIECE(X,U,10)=$PIECE(^LAB(61,+$PIECE(X0,U,2),0),U,1)
- +9 SET SPC($PIECE(X,U,4))=$PIECE(X,U,10)
- End DoDot:1
- +10 SET LST($$NXT)=X
- +11 SET LST($$NXT)="~Specimens"
- +12 SET SPC=0
- FOR
- SET SPC=$ORDER(SPC(SPC))
- if 'SPC
- QUIT
- SET LST($$NXT)=SPC_U_SPC(SPC)
- +13 QUIT
- ONESPEC(LST,IEN) ;return one specimen
- +1 if (+$GET(IEN)=0)!('$DATA(^LAB(61,IEN,0)))
- QUIT
- +2 SET LST=IEN_U_$PIECE(^LAB(61,IEN,0),U,1)
- +3 QUIT
- ABBSPEC(LST) ; procedure
- +1 ; returns specimens with abbreviation (uses 'E' xref)
- +2 NEW X,IEN,ILST
- SET ILST=0
- +3 SET X=""
- FOR
- SET X=$ORDER(^LAB(61,"E",X))
- if X=""
- QUIT
- SET IEN=$ORDER(^(X,0))
- Begin DoDot:1
- +4 SET LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1)
- End DoDot:1
- +5 QUIT
- NXT() ; called by TESTINFO, increments ILST
- +1 SET ILST=ILST+1
- +2 QUIT ILST
- +3 ;