- ORCDLR1 ;SLC/MKB,JFR - Utility fcns for LR dialogs cont ;8/29/02 14:45
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,79,141,243,296**;Dec 17, 1997;Build 19
- ;
- EN ; -- Entry Action for LR OTHER LAB TESTS order dialog
- D GETIMES S ORMAX=0
- S:$G(ORL) ORMAX=$$GET^XPAR("LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
- Q
- ;
- EX ; -- Exit Action for order dialog
- K ORTIME,ORCOLLCT,ORMAX,ORTEST,ORDIV,ORIMTIME,ORSMAX,ORSTMS,ORSCH,ORCAT
- I $G(ORXL) S ORL=ORXL K ORXL
- Q
- ;
- GETIMES ; -- Set list of routine collections into ORTIME($H)=FMtime
- N I,X,CNT,ON K ORTIME
- I '$D(VALIDT) D
- . S I=$$PTR^ORCD("OR GTX START DATE/TIME"),X=$P(ORDIALOG(I,0),U,2)
- . S X="T::ETX",$P(ORDIALOG(I,0),U,2)=X ; reset lower bound
- S ORDIV=+$P($G(^SC(+$G(ORL),0)),U,4) S:'ORDIV ORDIV=+$G(DUZ(2))
- I $G(OREVENT) S ORDIV=+$$DIV^OREVNTX(OREVENT),ORXL=$G(ORL),ORL=$$LOC^OREVNTX(OREVENT)
- D GETLST^XPAR(.ORTIME,ORDIV_";DIC(4,","LR PHLEBOTOMY COLLECTION","N")
- S (I,CNT)=0 F S I=$O(ORTIME(I)) Q:I'>0 S CNT=CNT+1,X=$P(ORTIME(I),U),ORTIME(I)=X,ORTIME("B",+("."_X))=I ; ORTIME($H time)=0000 FM time, ORTIME("B",.0000)=$H time of cut-off
- S ORTIME=CNT,I=$O(ORTIME(0)) S:I ORTIME("AM")=ORTIME(I) ; 1st collection
- S I=$O(ORTIME($P($H,",",2))) S:I ORTIME("NEXT")=ORTIME(I) ;NEXT coll
- S ON=$$ON^LR7OV4(ORDIV) D:ON SHOW^LR7OV4(ORDIV,.ORIMTIME)
- I 'ON,'$D(VALIDT) S I=$$PTR^ORCD("OR GTX COLLECTION TYPE"),X=$P(ORDIALOG(I,0),U,2),$P(ORDIALOG(I,0),U,2)=$P(X,";",1,3) ;Remove Immed if '$$ON
- Q
- ;
- DEFTIME() ; -- Returns default collection time
- I $L($G(LRFDATE)) S EDITONLY=1 Q LRFDATE
- I '$D(ORCOLLCT) Q ""
- N Y S Y="" I $D(^TMP("ORECALL",$J,ORDIALOG,PROMPT)) D Q:$L(Y) Y
- . S Y=$$RECALL^ORCD(PROMPT)
- . I '$S(ORCOLLCT="LC":$$LABCOLL(Y),ORCOLLCT="I":$$IMMCOLL(Y),1:$$CKDATE(Y)) S Y="" Q
- . S EDITONLY=1
- ;I $G(ORTYPE)="Q" Q $S(ORCOLLCT="LC":"AM",1:"")
- D LIST^ORCD:ORCOLLCT="LC"&$G(ORDIALOG(PROMPT,"LIST"))
- D IMMTIMES:ORCOLLCT="I"&$O(ORIMTIME(0))
- Q $S(ORCOLLCT="LC":"NEXT",ORCOLLCT="I":$$IMMDEF,ORCOLLCT="WC":"NOW",1:"TODAY")
- ;
- IMMDEF() ; -- Returns immediate collect default
- N X,Y S X=$$DEFTIME^LR7OV4(ORDIV)
- S Y=$S($P(X,U,3):"NOW+"_$P(X,U,3)_"'",1:$P(X,U))
- Q Y
- ;
- COLLTIME ; -- Get list of common collection times
- I ORCOLLCT="I" D:'$D(ORIMTIME) SHOW^LR7OV4(ORDIV,.ORIMTIME)
- I ORCOLLCT'="LC" K ORDIALOG(PROMPT,"LIST") Q
- Q:$G(ORDIALOG(PROMPT,"LIST")) Q:'$O(ORTIME(0))
- N I,X,CNT,NEXT,DAY,NOW S NOW=$P($H,",",2)
- S NEXT=$O(ORTIME(NOW)),DAY=$$NEXTCOLL($S(NEXT:"T",1:"T+1")) Q:DAY=""
- S:'NEXT!(DAY["+") NEXT=$O(ORTIME(0))
- S CNT=1,ORDIALOG(PROMPT,"LIST",1)="NEXT^NEXT Lab collection ("_DAY_"@"_$$TIME(ORTIME(NEXT))_")",ORDIALOG(PROMPT,"LIST","B","NEXT LAB COLLECTION")="NEXT"
- S ORDIALOG(PROMPT,"LIST","B","AM LAB COLLECTION")="AM"
- G:ORTIME'>1 CTMQ ; only NEXT
- S I=NEXT F S I=$O(ORTIME(I)) Q:I'>0 S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X
- I NEXT>$O(ORTIME(0)) D ;add morning times before NEXT to T+1
- . S DAY="T+"_(+$P(DAY,"+",2)+1),DAY=$$NEXTCOLL(DAY),I=$O(ORTIME(0))
- . S X=DAY_"@"_$$TIME(ORTIME("AM")),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)="AM^AM Lab collection ("_X_")"
- . F S I=$O(ORTIME(I)) Q:(I'>0)!(I'<NEXT) S X=DAY_"@"_$$TIME(ORTIME(I)),CNT=CNT+1,ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")",ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X
- CTMQ S ORDIALOG(PROMPT,"LIST")=CNT
- Q
- ;
- NEXTCOLL(START) ; -- Returns the next day that routine lab collects are done
- N X,Y,%DT,OFFSET,ORDAYS,PARAM I '$O(ORTIME(0)) Q "" ; no Lab collect
- S:'$D(START) START="T" S OFFSET=+$P(START,"+",2),START=$P(START,"+")
- F ORDAYS=1:1:7 D Q:$D(X) S OFFSET=OFFSET+1 ; ck up to a week
- . S %DT="X",X=START_$S(OFFSET:"+"_OFFSET,1:"")
- . D ^%DT I Y'>0 K X Q
- . I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q
- . S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(Y))
- . I '$$GET^XPAR("ALL",PARAM) K X Q
- . I '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY($P(Y,"."))) K X Q
- S Y=$S($D(X):X,1:"")
- Q Y
- ;
- TIME(X) ; -- Returns 00:00AM from 0000 FileMan time
- N HOUR,MIN,XM,Y
- S HOUR=$E(X,1,2),MIN=$E(X,3,4),XM="AM"
- I HOUR'<12 S XM="PM" S:HOUR>12 HOUR=HOUR-12
- S:$E(HOUR)="0" HOUR=$E(HOUR,2) ; strip leading 0
- S Y=HOUR_":"_MIN_XM
- Q Y
- ;
- LISTCOLL ; -- Lists the routine collection times for ??-help
- I '$O(ORTIME(0)) W !,"No routine lab collection times defined." Q
- N I,X S I=0,X=""
- F S I=$O(ORTIME(I)) Q:I'>0 S X=X_$S($L(X):", ",1:"")_$$TIME(ORTIME(I))
- W !,"Routine collection times are "_X_"."
- W !,"You may also enter AM for the morning collection, or NEXT for the next",!,"routine collection time."
- Q
- ;
- IMMTIMES ; -- Show the valid date/times for immediate collect
- N I S I=0
- F S I=$O(ORIMTIME(I)) Q:I'>0 W !,ORIMTIME(I)
- Q
- ;
- CKDATE(X) ; -- Valid coll time for SP or WC?
- S X=$$UP^XLFSTR(X) I ("NOW"[X)!("TODAY"[X) Q 1
- I X?1"T+"1.3N,+$P(X,"+",2)'>370 Q 1
- N Y,%DT,D
- I X'?7N.1".".6N S %DT="TX" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time"
- S D=$P(X,".") I D<DT Q "0^Cannot order for past days"
- I $P(X,".",2),X<$$NOW^XLFDT,'$G(OREVENT),$G(ORTYPE)'="Z" Q "0^The requested collection time has passed"
- I D>$$FMADD^XLFDT(DT,370) Q "0^Cannot order more than 370 days in advance"
- Q 1
- ;
- IMMCOLL(X) ; -- Valid immediate collection date/time?
- I X?1"NOW+"1.N1"'" Q 1
- I X'?7N.1".".6N N Y,%DT S %DT="T" D ^%DT S:Y>0 X=Y I Y'>0 Q "0^Invalid date/time"
- Q $$VALID^LR7OV4(ORDIV,X)
- ;
- LABCOLL(ORXTIM) ; -- Valid lab collection date/time?
- ; Returns valid flag of 1 or 0^message
- N I,X,Y,%DT,ORD,ORT,PARAM,ORDY
- I '$O(ORTIME(0)) Q "0^There are no lab collection times defined!"
- I (ORXTIM="AM")!(ORXTIM="NEXT") Q 1
- I ORXTIM'?7N.1".".6N S %DT="T",X=ORXTIM D ^%DT S:Y>0 ORXTIM=Y I Y'>0 Q "0^Invalid date/time"
- ;I ORXTIM?1"V".E S T="."_$P(ORXTIM,"@",2) G D1 ; Visit - ignore day (D ^%DT ??)
- S ORD=$P(ORXTIM,"."),ORT="."_$P(ORXTIM,".",2)
- S:ORT="." ORT=+("."_$G(ORTIME("AM")))
- I '$D(ORTIME("B",ORT)) Q "0^Invalid lab collection time"
- LC1 ; -- check date
- I ORD<DT Q "0^Can not order for past days."
- I ORXTIM<$$NOW^XLFDT,'$G(OREVENT) Q "0^Cannot order in the past"
- I $G(ORTYPE)'="Z",'$G(OREVENT),ORD=DT,$P($H,",",2)>ORTIME("B",ORT) Q "0^The cut-off time for this collection has passed"
- S ORDY=7 I $D(^XTV(8989.51,"B","LR LAB COLLECT FUTURE")),$G(ORL) S ORDY=+$$GET^XPAR("ALL^DIV.`"_ORDIV_"^LOC.`"_+ORL,"LR LAB COLLECT FUTURE",1,"I")
- I ORXTIM>$$FMADD^XLFDT($$NOW^XLFDT,ORDY) Q "0^Cannot order a lab collection more than "_ORDY_" days in advance"
- I $G(ORL),$$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS") Q 1
- S PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(ORD))
- I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL",PARAM) Q "0^There are no lab collections that day"
- I $G(ORTYPE)'="Z",'$$GET^XPAR("ALL","LR IGNORE HOLIDAYS"),$D(^HOLIDAY(ORD)) Q "0^There are no lab collections on holidays"
- Q 1
- ;
- LABSAMP() ; -- Lab Collect sample?
- N X,Y S X=+$$VAL^ORCD("COLLECTION SAMPLE"),Y=$P($G(^LAB(62,X,0)),U,7)
- Q Y
- ;
- COLLTYPE() ; -- Returns default collection type
- N Y I $G(ORTYPE)="Z" S Y="" G CTQ
- I $L($G(LRFZX)) S Y=LRFZX,EDITONLY=1 G CTQ
- I $D(^TMP("ORECALL",$J,+ORDIALOG,PROMPT)) D G CTQ
- . S Y=$$RECALL^ORCD(PROMPT),EDITONLY=1
- S:$G(ORL) Y=$$GET^XPAR("ALL^"_ORL,"LR DEFAULT TYPE QUICK")
- I '$L($G(Y)) S Y=$S('$$INPT^ORCD:"SP",$G(ORTYPE)="Q":"LC",1:"WC")
- CTQ I Y="I",'$O(ORIMTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC"
- I Y="LC",'$O(ORTIME(0))!('$G(ORTEST("Lab CollSamp"))) S Y="WC"
- ;S:$G(ORTYPE)="Q" EDITONLY=1
- I '(FIRST&EDITONLY) D HELPTYPE
- Q Y
- ;
- CKTYPE ; -- Valid type for time, sample?
- I Y="LC",'$O(ORTIME(0)) W $C(7),!,"There are no lab collection times defined!" K DONE Q
- I Y="I",'$O(ORIMTIME(0)) W $C(7),!,"There are no immediate collection times defined!" K DONE Q
- I (Y="LC"!(Y="I")),'$G(ORTEST("Lab CollSamp")) W $C(7),!,"There is no lab collection sample defined for this test!",! K DONE Q
- I $D(ORESET),ORESET'=Y,("ILC"[ORESET)!("ILC"[Y) D CHANGED^ORCDLR("TYPE") K ORDIALOG($$PTR^ORCD("OR GTX LAB URGENCY"),"LIST")
- Q
- ;
- HELPTYPE ; -- Xecutable help for Coll Type
- W !!,"SEND TO LAB - Means the patient is ambulatory and will be sent to the",!,"Laboratory draw room to have blood drawn."
- W !,"WARD COLLECT - Means that either the physician or a nurse will be collecting",!,"the sample on the ward."
- W !,"LAB BLOOD TEAM - Means the phlebotomist from Lab will draw the blood on the",!,"ward. This method is limited to laboratory defined collection times."
- W:$$ON^LR7OV4(ORDIV) !,"IMMEDIATE COLLECT BY BLOOD TEAM - Means the phlebotomist from Lab is on",!,"call to draw blood on the ward. This method is available during times",!,"defined by Laboratory." W !
- N DOMAIN S DOMAIN=$P(ORDIALOG(PROMPT,0),U,2) D SETLST1^ORCD
- Q
- VALID(ORDER) ;check collection time on release
- N VALIDT,OREVENT,COLLTYPE,COLLDT,OK,ORDIV,ORTXT,ORPTLK,ORTIME,ORIMTIME,ORACT
- S VALIDT="" D GETIMES
- S COLLDT=$$VALUE^ORCSAVE2(ORDER,"START")
- S COLLTYPE=$$VALUE^ORCSAVE2(ORDER,"COLLECT")
- I $L($P(^OR(100,+ORIFN,0),U,17)) S OREVENT=$P(^(0),U,17)
- I "NOWAMNEXT"[COLLDT D:'$G(OREVENT) MULT Q 1 ;OK
- S OK=$S(COLLTYPE="LC":$$LABCOLL(COLLDT),COLLTYPE="I":$$IMMCOLL(COLLDT),1:$$CKDATE(COLLDT))
- I OK D:'$G(OREVENT) MULT Q 1 ;COLLDT passed checks
- W !!,$C(7),$P(OK,U,2)
- D TEXT^ORQ12(.ORTXT,ORDER) W !,$G(ORTXT(1)) K ORTXT
- W !,"must be edited before signing/release." K VALIDT D
- . N ORDIV,ORIMTIME,ORTIME,ORNP
- . S ORNP=$P(^OR(100,ORDER,0),U,4)
- . S ORACT="XX" D XX^ORCACT4 ;edit order
- I $$VALUE^ORCSAVE2(ORDER,"START")'=COLLDT D:'$G(OREVENT) MULT Q 1 ;OK
- Q 0
- ;
- MULT ; -- ck child orders
- N CHGD S CHGD=$$MULT^ORCDLR(ORDER,COLLTYPE,COLLDT) Q:'CHGD
- W !!,$P(CHGD,U,2) H 2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCDLR1 9774 printed Jan 18, 2025@03:29:16 Page 2
- ORCDLR1 ;SLC/MKB,JFR - Utility fcns for LR dialogs cont ;8/29/02 14:45
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,29,49,61,79,141,243,296**;Dec 17, 1997;Build 19
- +2 ;
- EN ; -- Entry Action for LR OTHER LAB TESTS order dialog
- +1 DO GETIMES
- SET ORMAX=0
- +2 if $GET(ORL)
- SET ORMAX=$$GET^XPAR("LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
- +3 QUIT
- +4 ;
- EX ; -- Exit Action for order dialog
- +1 KILL ORTIME,ORCOLLCT,ORMAX,ORTEST,ORDIV,ORIMTIME,ORSMAX,ORSTMS,ORSCH,ORCAT
- +2 IF $GET(ORXL)
- SET ORL=ORXL
- KILL ORXL
- +3 QUIT
- +4 ;
- GETIMES ; -- Set list of routine collections into ORTIME($H)=FMtime
- +1 NEW I,X,CNT,ON
- KILL ORTIME
- +2 IF '$DATA(VALIDT)
- Begin DoDot:1
- +3 SET I=$$PTR^ORCD("OR GTX START DATE/TIME")
- SET X=$PIECE(ORDIALOG(I,0),U,2)
- +4 ; reset lower bound
- SET X="T::ETX"
- SET $PIECE(ORDIALOG(I,0),U,2)=X
- End DoDot:1
- +5 SET ORDIV=+$PIECE($GET(^SC(+$GET(ORL),0)),U,4)
- if 'ORDIV
- SET ORDIV=+$GET(DUZ(2))
- +6 IF $GET(OREVENT)
- SET ORDIV=+$$DIV^OREVNTX(OREVENT)
- SET ORXL=$GET(ORL)
- SET ORL=$$LOC^OREVNTX(OREVENT)
- +7 DO GETLST^XPAR(.ORTIME,ORDIV_";DIC(4,","LR PHLEBOTOMY COLLECTION","N")
- +8 ; ORTIME($H time)=0000 FM time, ORTIME("B",.0000)=$H time of cut-off
- SET (I,CNT)=0
- FOR
- SET I=$ORDER(ORTIME(I))
- if I'>0
- QUIT
- SET CNT=CNT+1
- SET X=$PIECE(ORTIME(I),U)
- SET ORTIME(I)=X
- SET ORTIME("B",+("."_X))=I
- +9 ; 1st collection
- SET ORTIME=CNT
- SET I=$ORDER(ORTIME(0))
- if I
- SET ORTIME("AM")=ORTIME(I)
- +10 ;NEXT coll
- SET I=$ORDER(ORTIME($PIECE($HOROLOG,",",2)))
- if I
- SET ORTIME("NEXT")=ORTIME(I)
- +11 SET ON=$$ON^LR7OV4(ORDIV)
- if ON
- DO SHOW^LR7OV4(ORDIV,.ORIMTIME)
- +12 ;Remove Immed if '$$ON
- IF 'ON
- IF '$DATA(VALIDT)
- SET I=$$PTR^ORCD("OR GTX COLLECTION TYPE")
- SET X=$PIECE(ORDIALOG(I,0),U,2)
- SET $PIECE(ORDIALOG(I,0),U,2)=$PIECE(X,";",1,3)
- +13 QUIT
- +14 ;
- DEFTIME() ; -- Returns default collection time
- +1 IF $LENGTH($GET(LRFDATE))
- SET EDITONLY=1
- QUIT LRFDATE
- +2 IF '$DATA(ORCOLLCT)
- QUIT ""
- +3 NEW Y
- SET Y=""
- IF $DATA(^TMP("ORECALL",$JOB,ORDIALOG,PROMPT))
- Begin DoDot:1
- +4 SET Y=$$RECALL^ORCD(PROMPT)
- +5 IF '$SELECT(ORCOLLCT="LC":$$LABCOLL(Y),ORCOLLCT="I":$$IMMCOLL(Y),1:$$CKDATE(Y))
- SET Y=""
- QUIT
- +6 SET EDITONLY=1
- End DoDot:1
- if $LENGTH(Y)
- QUIT Y
- +7 ;I $G(ORTYPE)="Q" Q $S(ORCOLLCT="LC":"AM",1:"")
- +8 if ORCOLLCT="LC"&$GET(ORDIALOG(PROMPT,"LIST"))
- DO LIST^ORCD
- +9 if ORCOLLCT="I"&$ORDER(ORIMTIME(0))
- DO IMMTIMES
- +10 QUIT $SELECT(ORCOLLCT="LC":"NEXT",ORCOLLCT="I":$$IMMDEF,ORCOLLCT="WC":"NOW",1:"TODAY")
- +11 ;
- IMMDEF() ; -- Returns immediate collect default
- +1 NEW X,Y
- SET X=$$DEFTIME^LR7OV4(ORDIV)
- +2 SET Y=$SELECT($PIECE(X,U,3):"NOW+"_$PIECE(X,U,3)_"'",1:$PIECE(X,U))
- +3 QUIT Y
- +4 ;
- COLLTIME ; -- Get list of common collection times
- +1 IF ORCOLLCT="I"
- if '$DATA(ORIMTIME)
- DO SHOW^LR7OV4(ORDIV,.ORIMTIME)
- +2 IF ORCOLLCT'="LC"
- KILL ORDIALOG(PROMPT,"LIST")
- QUIT
- +3 if $GET(ORDIALOG(PROMPT,"LIST"))
- QUIT
- if '$ORDER(ORTIME(0))
- QUIT
- +4 NEW I,X,CNT,NEXT,DAY,NOW
- SET NOW=$PIECE($HOROLOG,",",2)
- +5 SET NEXT=$ORDER(ORTIME(NOW))
- SET DAY=$$NEXTCOLL($SELECT(NEXT:"T",1:"T+1"))
- if DAY=""
- QUIT
- +6 if 'NEXT!(DAY["+")
- SET NEXT=$ORDER(ORTIME(0))
- +7 SET CNT=1
- SET ORDIALOG(PROMPT,"LIST",1)="NEXT^NEXT Lab collection ("_DAY_"@"_$$TIME(ORTIME(NEXT))_")"
- SET ORDIALOG(PROMPT,"LIST","B","NEXT LAB COLLECTION")="NEXT"
- +8 SET ORDIALOG(PROMPT,"LIST","B","AM LAB COLLECTION")="AM"
- +9 ; only NEXT
- if ORTIME'>1
- GOTO CTMQ
- +10 SET I=NEXT
- FOR
- SET I=$ORDER(ORTIME(I))
- if I'>0
- QUIT
- SET X=DAY_"@"_$$TIME(ORTIME(I))
- SET CNT=CNT+1
- SET ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")"
- SET ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X
- +11 ;add morning times before NEXT to T+1
- IF NEXT>$ORDER(ORTIME(0))
- Begin DoDot:1
- +12 SET DAY="T+"_(+$PIECE(DAY,"+",2)+1)
- SET DAY=$$NEXTCOLL(DAY)
- SET I=$ORDER(ORTIME(0))
- +13 SET X=DAY_"@"_$$TIME(ORTIME("AM"))
- SET CNT=CNT+1
- SET ORDIALOG(PROMPT,"LIST",CNT)="AM^AM Lab collection ("_X_")"
- +14 FOR
- SET I=$ORDER(ORTIME(I))
- if (I'>0)!(I'<NEXT)
- QUIT
- SET X=DAY_"@"_$$TIME(ORTIME(I))
- SET CNT=CNT+1
- SET ORDIALOG(PROMPT,"LIST",CNT)=X_"^Routine Lab collection ("_X_")"
- SET ORDIALOG(PROMPT,"LIST","B","ROUTINE LAB COLLECTION")=X
- End DoDot:1
- CTMQ SET ORDIALOG(PROMPT,"LIST")=CNT
- +1 QUIT
- +2 ;
- NEXTCOLL(START) ; -- Returns the next day that routine lab collects are done
- +1 ; no Lab collect
- NEW X,Y,%DT,OFFSET,ORDAYS,PARAM
- IF '$ORDER(ORTIME(0))
- QUIT ""
- +2 if '$DATA(START)
- SET START="T"
- SET OFFSET=+$PIECE(START,"+",2)
- SET START=$PIECE(START,"+")
- +3 ; ck up to a week
- FOR ORDAYS=1:1:7
- Begin DoDot:1
- +4 SET %DT="X"
- SET X=START_$SELECT(OFFSET:"+"_OFFSET,1:"")
- +5 DO ^%DT
- IF Y'>0
- KILL X
- QUIT
- +6 IF $GET(ORL)
- IF $$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS")
- QUIT
- +7 SET PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(Y))
- +8 IF '$$GET^XPAR("ALL",PARAM)
- KILL X
- QUIT
- +9 IF '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS")
- IF $DATA(^HOLIDAY($PIECE(Y,".")))
- KILL X
- QUIT
- End DoDot:1
- if $DATA(X)
- QUIT
- SET OFFSET=OFFSET+1
- +10 SET Y=$SELECT($DATA(X):X,1:"")
- +11 QUIT Y
- +12 ;
- TIME(X) ; -- Returns 00:00AM from 0000 FileMan time
- +1 NEW HOUR,MIN,XM,Y
- +2 SET HOUR=$EXTRACT(X,1,2)
- SET MIN=$EXTRACT(X,3,4)
- SET XM="AM"
- +3 IF HOUR'<12
- SET XM="PM"
- if HOUR>12
- SET HOUR=HOUR-12
- +4 ; strip leading 0
- if $EXTRACT(HOUR)="0"
- SET HOUR=$EXTRACT(HOUR,2)
- +5 SET Y=HOUR_":"_MIN_XM
- +6 QUIT Y
- +7 ;
- LISTCOLL ; -- Lists the routine collection times for ??-help
- +1 IF '$ORDER(ORTIME(0))
- WRITE !,"No routine lab collection times defined."
- QUIT
- +2 NEW I,X
- SET I=0
- SET X=""
- +3 FOR
- SET I=$ORDER(ORTIME(I))
- if I'>0
- QUIT
- SET X=X_$SELECT($LENGTH(X):", ",1:"")_$$TIME(ORTIME(I))
- +4 WRITE !,"Routine collection times are "_X_"."
- +5 WRITE !,"You may also enter AM for the morning collection, or NEXT for the next",!,"routine collection time."
- +6 QUIT
- +7 ;
- IMMTIMES ; -- Show the valid date/times for immediate collect
- +1 NEW I
- SET I=0
- +2 FOR
- SET I=$ORDER(ORIMTIME(I))
- if I'>0
- QUIT
- WRITE !,ORIMTIME(I)
- +3 QUIT
- +4 ;
- CKDATE(X) ; -- Valid coll time for SP or WC?
- +1 SET X=$$UP^XLFSTR(X)
- IF ("NOW"[X)!("TODAY"[X)
- QUIT 1
- +2 IF X?1"T+"1.3N
- IF +$PIECE(X,"+",2)'>370
- QUIT 1
- +3 NEW Y,%DT,D
- +4 IF X'?7N.1".".6N
- SET %DT="TX"
- DO ^%DT
- if Y>0
- SET X=Y
- IF Y'>0
- QUIT "0^Invalid date/time"
- +5 SET D=$PIECE(X,".")
- IF D<DT
- QUIT "0^Cannot order for past days"
- +6 IF $PIECE(X,".",2)
- IF X<$$NOW^XLFDT
- IF '$GET(OREVENT)
- IF $GET(ORTYPE)'="Z"
- QUIT "0^The requested collection time has passed"
- +7 IF D>$$FMADD^XLFDT(DT,370)
- QUIT "0^Cannot order more than 370 days in advance"
- +8 QUIT 1
- +9 ;
- IMMCOLL(X) ; -- Valid immediate collection date/time?
- +1 IF X?1"NOW+"1.N1"'"
- QUIT 1
- +2 IF X'?7N.1".".6N
- NEW Y,%DT
- SET %DT="T"
- DO ^%DT
- if Y>0
- SET X=Y
- IF Y'>0
- QUIT "0^Invalid date/time"
- +3 QUIT $$VALID^LR7OV4(ORDIV,X)
- +4 ;
- LABCOLL(ORXTIM) ; -- Valid lab collection date/time?
- +1 ; Returns valid flag of 1 or 0^message
- +2 NEW I,X,Y,%DT,ORD,ORT,PARAM,ORDY
- +3 IF '$ORDER(ORTIME(0))
- QUIT "0^There are no lab collection times defined!"
- +4 IF (ORXTIM="AM")!(ORXTIM="NEXT")
- QUIT 1
- +5 IF ORXTIM'?7N.1".".6N
- SET %DT="T"
- SET X=ORXTIM
- DO ^%DT
- if Y>0
- SET ORXTIM=Y
- IF Y'>0
- QUIT "0^Invalid date/time"
- +6 ;I ORXTIM?1"V".E S T="."_$P(ORXTIM,"@",2) G D1 ; Visit - ignore day (D ^%DT ??)
- +7 SET ORD=$PIECE(ORXTIM,".")
- SET ORT="."_$PIECE(ORXTIM,".",2)
- +8 if ORT="."
- SET ORT=+("."_$GET(ORTIME("AM")))
- +9 IF '$DATA(ORTIME("B",ORT))
- QUIT "0^Invalid lab collection time"
- LC1 ; -- check date
- +1 IF ORD<DT
- QUIT "0^Can not order for past days."
- +2 IF ORXTIM<$$NOW^XLFDT
- IF '$GET(OREVENT)
- QUIT "0^Cannot order in the past"
- +3 IF $GET(ORTYPE)'="Z"
- IF '$GET(OREVENT)
- IF ORD=DT
- IF $PIECE($HOROLOG,",",2)>ORTIME("B",ORT)
- QUIT "0^The cut-off time for this collection has passed"
- +4 SET ORDY=7
- IF $DATA(^XTV(8989.51,"B","LR LAB COLLECT FUTURE"))
- IF $GET(ORL)
- SET ORDY=+$$GET^XPAR("ALL^DIV.`"_ORDIV_"^LOC.`"_+ORL,"LR LAB COLLECT FUTURE",1,"I")
- +5 IF ORXTIM>$$FMADD^XLFDT($$NOW^XLFDT,ORDY)
- QUIT "0^Cannot order a lab collection more than "_ORDY_" days in advance"
- +6 IF $GET(ORL)
- IF $$GET^XPAR("ALL^LOC.`"_+ORL,"LR EXCEPTED LOCATIONS")
- QUIT 1
- +7 SET PARAM="LR COLLECT "_$$UP^XLFSTR($$DOW^XLFDT(ORD))
- +8 IF $GET(ORTYPE)'="Z"
- IF '$$GET^XPAR("ALL",PARAM)
- QUIT "0^There are no lab collections that day"
- +9 IF $GET(ORTYPE)'="Z"
- IF '$$GET^XPAR("ALL","LR IGNORE HOLIDAYS")
- IF $DATA(^HOLIDAY(ORD))
- QUIT "0^There are no lab collections on holidays"
- +10 QUIT 1
- +11 ;
- LABSAMP() ; -- Lab Collect sample?
- +1 NEW X,Y
- SET X=+$$VAL^ORCD("COLLECTION SAMPLE")
- SET Y=$PIECE($GET(^LAB(62,X,0)),U,7)
- +2 QUIT Y
- +3 ;
- COLLTYPE() ; -- Returns default collection type
- +1 NEW Y
- IF $GET(ORTYPE)="Z"
- SET Y=""
- GOTO CTQ
- +2 IF $LENGTH($GET(LRFZX))
- SET Y=LRFZX
- SET EDITONLY=1
- GOTO CTQ
- +3 IF $DATA(^TMP("ORECALL",$JOB,+ORDIALOG,PROMPT))
- Begin DoDot:1
- +4 SET Y=$$RECALL^ORCD(PROMPT)
- SET EDITONLY=1
- End DoDot:1
- GOTO CTQ
- +5 if $GET(ORL)
- SET Y=$$GET^XPAR("ALL^"_ORL,"LR DEFAULT TYPE QUICK")
- +6 IF '$LENGTH($GET(Y))
- SET Y=$SELECT('$$INPT^ORCD:"SP",$GET(ORTYPE)="Q":"LC",1:"WC")
- CTQ IF Y="I"
- IF '$ORDER(ORIMTIME(0))!('$GET(ORTEST("Lab CollSamp")))
- SET Y="WC"
- +1 IF Y="LC"
- IF '$ORDER(ORTIME(0))!('$GET(ORTEST("Lab CollSamp")))
- SET Y="WC"
- +2 ;S:$G(ORTYPE)="Q" EDITONLY=1
- +3 IF '(FIRST&EDITONLY)
- DO HELPTYPE
- +4 QUIT Y
- +5 ;
- CKTYPE ; -- Valid type for time, sample?
- +1 IF Y="LC"
- IF '$ORDER(ORTIME(0))
- WRITE $CHAR(7),!,"There are no lab collection times defined!"
- KILL DONE
- QUIT
- +2 IF Y="I"
- IF '$ORDER(ORIMTIME(0))
- WRITE $CHAR(7),!,"There are no immediate collection times defined!"
- KILL DONE
- QUIT
- +3 IF (Y="LC"!(Y="I"))
- IF '$GET(ORTEST("Lab CollSamp"))
- WRITE $CHAR(7),!,"There is no lab collection sample defined for this test!",!
- KILL DONE
- QUIT
- +4 IF $DATA(ORESET)
- IF ORESET'=Y
- IF ("ILC"[ORESET)!("ILC"[Y)
- DO CHANGED^ORCDLR("TYPE")
- KILL ORDIALOG($$PTR^ORCD("OR GTX LAB URGENCY"),"LIST")
- +5 QUIT
- +6 ;
- HELPTYPE ; -- Xecutable help for Coll Type
- +1 WRITE !!,"SEND TO LAB - Means the patient is ambulatory and will be sent to the",!,"Laboratory draw room to have blood drawn."
- +2 WRITE !,"WARD COLLECT - Means that either the physician or a nurse will be collecting",!,"the sample on the ward."
- +3 WRITE !,"LAB BLOOD TEAM - Means the phlebotomist from Lab will draw the blood on the",!,"ward. This method is limited to laboratory defined collection times."
- +4 if $$ON^LR7OV4(ORDIV)
- WRITE !,"IMMEDIATE COLLECT BY BLOOD TEAM - Means the phlebotomist from Lab is on",!,"call to draw blood on the ward. This method is available during times",!,"defined by Laboratory."
- WRITE !
- +5 NEW DOMAIN
- SET DOMAIN=$PIECE(ORDIALOG(PROMPT,0),U,2)
- DO SETLST1^ORCD
- +6 QUIT
- VALID(ORDER) ;check collection time on release
- +1 NEW VALIDT,OREVENT,COLLTYPE,COLLDT,OK,ORDIV,ORTXT,ORPTLK,ORTIME,ORIMTIME,ORACT
- +2 SET VALIDT=""
- DO GETIMES
- +3 SET COLLDT=$$VALUE^ORCSAVE2(ORDER,"START")
- +4 SET COLLTYPE=$$VALUE^ORCSAVE2(ORDER,"COLLECT")
- +5 IF $LENGTH($PIECE(^OR(100,+ORIFN,0),U,17))
- SET OREVENT=$PIECE(^(0),U,17)
- +6 ;OK
- IF "NOWAMNEXT"[COLLDT
- if '$GET(OREVENT)
- DO MULT
- QUIT 1
- +7 SET OK=$SELECT(COLLTYPE="LC":$$LABCOLL(COLLDT),COLLTYPE="I":$$IMMCOLL(COLLDT),1:$$CKDATE(COLLDT))
- +8 ;COLLDT passed checks
- IF OK
- if '$GET(OREVENT)
- DO MULT
- QUIT 1
- +9 WRITE !!,$CHAR(7),$PIECE(OK,U,2)
- +10 DO TEXT^ORQ12(.ORTXT,ORDER)
- WRITE !,$GET(ORTXT(1))
- KILL ORTXT
- +11 WRITE !,"must be edited before signing/release."
- KILL VALIDT
- Begin DoDot:1
- +12 NEW ORDIV,ORIMTIME,ORTIME,ORNP
- +13 SET ORNP=$PIECE(^OR(100,ORDER,0),U,4)
- +14 ;edit order
- SET ORACT="XX"
- DO XX^ORCACT4
- End DoDot:1
- +15 ;OK
- IF $$VALUE^ORCSAVE2(ORDER,"START")'=COLLDT
- if '$GET(OREVENT)
- DO MULT
- QUIT 1
- +16 QUIT 0
- +17 ;
- MULT ; -- ck child orders
- +1 NEW CHGD
- SET CHGD=$$MULT^ORCDLR(ORDER,COLLTYPE,COLLDT)
- if 'CHGD
- QUIT
- +2 WRITE !!,$PIECE(CHGD,U,2)
- HANG 2
- +3 QUIT