- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDLR.m
r613 r623 1 ORWDLR ; SLC/KCM - Lab Calls [ 08/04/96 8:47 PM ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17, 1997;Build 242 3 ; 4 DEF(LST,ALOC) ; procedure 5 ; get dialog definition specific to lab 6 S ILST=0 7 S LST($$NXT)="~Collection Times" D COLLTM 8 S LST($$NXT)="~Send Patient Times" D SENDTM 9 S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3 10 ; S LST($$NXT)="~Urgencies Map" D URGMAP 11 S LST($$NXT)="~Schedules" D SCHED 12 S LST($$NXT)="~Common" D COMMON 13 Q 14 COLLTM ; get collection times 15 N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT 16 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H 17 M TMRW=TDAY D INCDATE(.TMRW) 18 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D 19 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") 20 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") 21 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") 22 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") 23 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") 24 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") 25 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") 26 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") 27 . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 28 . . D INCDATE(.TDAY) S CNT=CNT+1 29 . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 30 . . D INCDATE(.TMRW) S CNT=CNT+1 31 D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") 32 S ICTM=0 F S ICTM=$O(CTM(ICTM)) Q:'ICTM D 33 . I $P(CTM(ICTM),U)>$P($H,",",2) D 34 . . S FMDT=TDAY 35 . . I +TDAY("H")=+$H S DAY="Today" 36 . . I TDAY("H")-$H=1 S DAY="Tomorrow" 37 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) 38 . E D 39 . . S FMDT=TMRW 40 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") 41 . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM") 42 . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2) 43 . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) 44 . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" 45 D NOW^%DTC 46 S LST($$NXT)="iW"_%_"^Now (Collect on ward)" 47 Q 48 SENDTM ; get send patient times 49 N X,X1,X2 50 S LST($$NXT)="iL"_DT_"^Today" 51 S X1=DT,X2=1 D C^%DTC 52 S LST($$NXT)="iL"_X_"^Tomorrow" 53 Q 54 INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE 55 N X,X1,X2,%H 56 S X1=ADATE,X2=1 D C^%DTC S ADATE=X 57 S ADATE("H")=ADATE("H")+1 58 S ADATE("DOW")=ADATE("H")#7 59 Q 60 DOWNAME(DOW) ; function 61 ; Returns Day of Week name (DOW should be $H#7) 62 I DOW=0 Q "Thursday" 63 I DOW=1 Q "Friday" 64 I DOW=2 Q "Saturday" 65 I DOW=3 Q "Sunday" 66 I DOW=4 Q "Monday" 67 I DOW=5 Q "Tuesday" 68 I DOW=6 Q "Wednesday" 69 Q "" 70 URGMAP ; return list of lab urgencies mapped to OE/RR urgencies 71 Q 72 N I,X 73 S I=0 F S I=$O(^LAB(62.05,I)) Q:'I S X=^(I,0) I '$P(X,U,3) D 74 . S LST($$NXT)="i"_I_"="_I_U_$P(X,U) 75 ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N") 76 ; S URG=0 F S URG=$O(Y(URG)) Q:'URG S LST($$NXT)="i"_URG_"="_Y(URG) 77 Q 78 SCHED ; return list of schedules available for lab tests 79 N X,IEN 80 K ^TMP($J,"ORWDLR APLR") 81 D AP^PSS51P1("LR",,,,"ORWDLR APLR") 82 S X="" F S X=$O(^TMP($J,"ORWDLR APLR","APLR",X)) Q:X="" D 83 . S IEN=$O(^TMP($J,"ORWDLR APLR","APLR",X,"")) I IEN'>0 Q 84 . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^TMP($J,"ORWDLR APLR",IEN,5)),U) 85 . I X="ONE TIME" S LST($$NXT)="d"_X 86 K ^TMP($J,"ORWDLR APLR") 87 Q 88 COMMON ; return list of commonly ordered lab tests 89 N TMPLST,IEN,I 90 D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT") 91 S I=0 F S I=$O(TMPLST(I)) Q:'I D 92 . S IEN=$P(TMPLST(I),U,2) 93 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) 94 Q 95 LOAD(LST,TESTID) ; procedure 96 ; Return sample, specimen, & urgency info about a lab test 97 N X,Y,ILST,PARAM S ILST=0 98 S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1) 99 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" 100 S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) 101 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) 102 D TEST^LR7OR3(TESTID,.Y) 103 S PARAM="" F S PARAM=$O(Y(PARAM)) Q:PARAM="" D 104 . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM))) 105 . I $D(Y(PARAM))>1 S I=0 F S I=$O(Y(PARAM,I)) Q:'I D 106 . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q 107 . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q 108 . . S LST($$NXT)="i"_I_U_Y(PARAM,I) 109 . . I PARAM="CollSamp" D 110 . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1 111 . . . S X=+$P(Y(PARAM,I),U,3) 112 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) 113 . . I $D(Y(PARAM,I,"WP")) S J=0 F S J=$O(Y(PARAM,I,"WP",J)) Q:'J D 114 . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0) 115 Q 116 ALLSAMP(LST) ; procedure 117 ; returns all collection samples 118 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName 119 N SMP,SPC,ILST,IEN,X,X0 120 S ILST=0,LST($$NXT)="~CollSamp" 121 S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D 122 . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D 123 . . S X0=^LAB(62,IEN,0) 124 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) 125 . . I $P(X0,U,2) D 126 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) 127 . . . S SPC($P(X,U,4))=$P(X,U,10) 128 . . S LST($$NXT)=X 129 S LST($$NXT)="~Specimens" 130 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) 131 Q 132 ABBSPEC(LST) ; procedure 133 ; returns specimens with abbreviation (uses 'E' xref) 134 N X,IEN,ILST S ILST=0 135 S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D 136 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) 137 Q 138 NXT() ; called by TESTINFO, increments ILST 139 S ILST=ILST+1 140 Q ILST 141 STOP(VAL,X2) ; return a calculated stop date 142 N X1,X 143 S X1=DT D C^%DTC S VAL=X 144 Q 1 ORWDLR ; SLC/KCM - Lab Calls [ 08/04/96 8:47 PM ] 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997 3 ; 4 DEF(LST,ALOC) ; procedure 5 ; get dialog definition specific to lab 6 S ILST=0 7 S LST($$NXT)="~Collection Times" D COLLTM 8 S LST($$NXT)="~Send Patient Times" D SENDTM 9 S LST($$NXT)="~Default Urgency="_$$DEFURG^LR7OR3 10 ; S LST($$NXT)="~Urgencies Map" D URGMAP 11 S LST($$NXT)="~Schedules" D SCHED 12 S LST($$NXT)="~Common" D COMMON 13 Q 14 COLLTM ; get collection times 15 N TDAY,TMRW,IGNOR,CNT,ICTM,CTM,DOW,AMPM,DAY,TIME,FMDT 16 S TDAY=DT,TDAY("DOW")=$H#7,TDAY("H")=$H 17 M TMRW=TDAY D INCDATE(.TMRW) 18 I $G(ALOC),'$$GET^XPAR(ALOC_";SC(","LR EXCEPTED LOCATIONS",1,"Q") D 19 . S IGNOR=$$GET^XPAR("ALL","LR IGNORE HOLIDAYS",1,"Q") 20 . S DOW(0)=$$GET^XPAR("ALL","LR COLLECT THURSDAY",1,"Q") 21 . S DOW(1)=$$GET^XPAR("ALL","LR COLLECT FRIDAY",1,"Q") 22 . S DOW(2)=$$GET^XPAR("ALL","LR COLLECT SATURDAY",1,"Q") 23 . S DOW(3)=$$GET^XPAR("ALL","LR COLLECT SUNDAY",1,"Q") 24 . S DOW(4)=$$GET^XPAR("ALL","LR COLLECT MONDAY",1,"Q") 25 . S DOW(5)=$$GET^XPAR("ALL","LR COLLECT TUESDAY",1,"Q") 26 . S DOW(6)=$$GET^XPAR("ALL","LR COLLECT WEDNESDAY",1,"Q") 27 . S CNT=0 F Q:(DOW(TDAY("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TDAY,0)))) D Q:CNT>6 28 . . D INCDATE(.TDAY) S CNT=CNT+1 29 . S CNT=0 F Q:(DOW(TMRW("DOW"))=1)&((IGNOR=1)!('$D(^HOLIDAY(TMRW,0)))) D Q:CNT>6 30 . . D INCDATE(.TMRW) S CNT=CNT+1 31 D GETLST^XPAR(.CTM,"ALL","LR PHLEBOTOMY COLLECTION","Q") 32 S ICTM=0 F S ICTM=$O(CTM(ICTM)) Q:'ICTM D 33 . I $P(CTM(ICTM),U)>$P($H,",",2) D 34 . . S FMDT=TDAY 35 . . I +TDAY("H")=+$H S DAY="Today" 36 . . I TDAY("H")-$H=1 S DAY="Tomorrow" 37 . . I TDAY("H")-$H>1 S DAY=$$DOWNAME(TDAY("DOW")) 38 . E D 39 . . S FMDT=TMRW 40 . . S DAY=$S(TMRW("H")-$H>1:$$DOWNAME(TMRW("DOW")),1:"Tomorrow") 41 . S AMPM=$S($P(CTM(ICTM),U,2)>1159:"PM",1:"AM") 42 . S FMDT=FMDT_"."_$P(CTM(ICTM),"^",2) 43 . S TIME=$P(CTM(ICTM),U,2),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) 44 . S LST($$NXT)="iL"_FMDT_U_AMPM_" Collection: "_TIME_" ("_DAY_")" 45 D NOW^%DTC 46 S LST($$NXT)="iW"_%_"^Now (Collect on ward)" 47 Q 48 SENDTM ; get send patient times 49 N X,X1,X2 50 S LST($$NXT)="iL"_DT_"^Today" 51 S X1=DT,X2=1 D C^%DTC 52 S LST($$NXT)="iL"_X_"^Tomorrow" 53 Q 54 INCDATE(ADATE) ; called from COLLTM, increments date nodes in .ADATE 55 N X,X1,X2,%H 56 S X1=ADATE,X2=1 D C^%DTC S ADATE=X 57 S ADATE("H")=ADATE("H")+1 58 S ADATE("DOW")=ADATE("H")#7 59 Q 60 DOWNAME(DOW) ; function 61 ; Returns Day of Week name (DOW should be $H#7) 62 I DOW=0 Q "Thursday" 63 I DOW=1 Q "Friday" 64 I DOW=2 Q "Saturday" 65 I DOW=3 Q "Sunday" 66 I DOW=4 Q "Monday" 67 I DOW=5 Q "Tuesday" 68 I DOW=6 Q "Wednesday" 69 Q "" 70 URGMAP ; return list of lab urgencies mapped to OE/RR urgencies 71 Q 72 N I,X 73 S I=0 F S I=$O(^LAB(62.05,I)) Q:'I S X=^(I,0) I '$P(X,U,3) D 74 . S LST($$NXT)="i"_I_"="_I_U_$P(X,U) 75 ; D GETLST^XPAR(.Y,"ALL","ORCDLR URGENCIES","N") 76 ; S URG=0 F S URG=$O(Y(URG)) Q:'URG S LST($$NXT)="i"_URG_"="_Y(URG) 77 Q 78 SCHED ; return list of schedules available for lab tests 79 N X,IEN 80 S X="" F S X=$O(^PS(51.1,"APLR",X)) Q:X="" S IEN=$O(^(X,0)) I IEN D 81 . S LST($$NXT)="i"_IEN_U_X_U_$P($G(^PS(51.1,IEN,0)),U,5) 82 . I X="ONE TIME" S LST($$NXT)="d"_X 83 Q 84 COMMON ; return list of commonly ordered lab tests 85 N TMPLST,IEN,I 86 D GETLST^XPAR(.TMPLST,"ALL","ORWD COMMON LAB INPT") 87 S I=0 F S I=$O(TMPLST(I)) Q:'I D 88 . S IEN=$P(TMPLST(I),U,2) 89 . S LST($$NXT)="i"_IEN_U_$P(^ORD(101.43,IEN,0),U,1) 90 Q 91 LOAD(LST,TESTID) ; procedure 92 ; Return sample, specimen, & urgency info about a lab test 93 N X,Y,ILST,PARAM S ILST=0 94 S LST($$NXT)="~Test Name="_$P(^ORD(101.43,TESTID,0),U,1) 95 I $D(^ORD(101.43,TESTID,8))>1 S LST($$NXT)="~OIMessage" 96 S I=0 F S I=$O(^ORD(101.43,TESTID,8,I)) Q:'I S LST($$NXT)="t"_^(I,0) 97 S TESTID=+$P(^ORD(101.43,TESTID,0),U,2) 98 D TEST^LR7OR3(TESTID,.Y) 99 S PARAM="" F S PARAM=$O(Y(PARAM)) Q:PARAM="" D 100 . S LST($$NXT)="~"_PARAM_$S($D(Y(PARAM))>1:"",1:"="_$G(Y(PARAM))) 101 . I $D(Y(PARAM))>1 S I=0 F S I=$O(Y(PARAM,I)) Q:'I D 102 . . I PARAM="Specimens" S LST($$NXT)="i"_Y(PARAM,I) Q 103 . . I PARAM="Urgencies" S LST($$NXT)="i"_Y(PARAM,I) Q 104 . . S LST($$NXT)="i"_I_U_Y(PARAM,I) 105 . . I PARAM="CollSamp" D 106 . . . I $G(Y("Lab CollSamp")) S $P(LST(ILST),U,8)=1 107 . . . S X=+$P(Y(PARAM,I),U,3) 108 . . . I X S $P(LST(ILST),U,10)=$P($G(^LAB(61,X,0)),U,1) 109 . . I $D(Y(PARAM,I,"WP")) S J=0 F S J=$O(Y(PARAM,I,"WP",J)) Q:'J D 110 . . . S LST($$NXT)="t"_Y(PARAM,I,"WP",J,0) 111 Q 112 ALLSAMP(LST) ; procedure 113 ; returns all collection samples 114 ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName 115 N SMP,SPC,ILST,IEN,X,X0 116 S ILST=0,LST($$NXT)="~CollSamp" 117 S SMP="" F S SMP=$O(^LAB(62,"B",SMP)) Q:SMP="" D 118 . S IEN=0 F S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN D 119 . . S X0=^LAB(62,IEN,0) 120 . . S X="i"_U_IEN_U_SMP_U_$P(X0,U,2)_U_$P(X0,U,3)_U_U_U_$P(X0,U,7) 121 . . I $P(X0,U,2) D 122 . . . S $P(X,U,10)=$P(^LAB(61,+$P(X0,U,2),0),U,1) 123 . . . S SPC($P(X,U,4))=$P(X,U,10) 124 . . S LST($$NXT)=X 125 S LST($$NXT)="~Specimens" 126 S SPC=0 F S SPC=$O(SPC(SPC)) Q:'SPC S LST($$NXT)=SPC_U_SPC(SPC) 127 Q 128 ABBSPEC(LST) ; procedure 129 ; returns specimens with abbreviation (uses 'E' xref) 130 N X,IEN,ILST S ILST=0 131 S X="" F S X=$O(^LAB(61,"E",X)) Q:X="" S IEN=$O(^(X,0)) D 132 . S LST($$NXT)=IEN_U_$P(^LAB(61,IEN,0),U,1) 133 Q 134 NXT() ; called by TESTINFO, increments ILST 135 S ILST=ILST+1 136 Q ILST 137 STOP(VAL,X2) ; return a calculated stop date 138 N X1,X 139 S X1=DT D C^%DTC S VAL=X 140 Q
Note:
See TracChangeset
for help on using the changeset viewer.
