source: WorldVistAEHR/trunk/r/ONCOLOGY-ONC/ONCODXD.m@ 814

Last change on this file since 814 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1ONCODXD ;Hines OIFO/RTK,GWB - DATE DX (165.5,3) INPUT TRANSFORM ;4/9/97
2 ;;2.11;ONCOLOGY;**11,13,15,16,18,36,47**;Mar 07,1995;Build 19
3 ;
4DTDXIT ;Check that date entered is BEFORE or EQUAL to all other DATE fields
5 S DTXFLAG=1,C=0,MULT="" K LIST,SBCT,SUBR,RADT D CHKDTS
6 I DTXFLAG=1 D KLL Q
7 K X W !?4,"The DATE DX must be BEFORE or EQUAL TO certain date fields. The date"
8 W !?4,"you have entered is unacceptable because it is AFTER the"
9 W !?4,"following date field(s):",!
10 F RTK=0:0 S RTK=$O(LIST(RTK)) Q:RTK'>"" D
11 .S INDT=$P(LIST(RTK),U,2) D DT
12 .W !?4,EXDT," - ",$P(LIST(RTK),U,1) Q
13 F RTK=0:0 S RTK=$O(SBCT(RTK)) Q:RTK'>"" D
14 .S INDT=$P(SBCT(RTK),U,2) D DT
15 .W !?4,EXDT," - SUBSEQUENT COURSE TREATMENT ",$P(SBCT(RTK),U,3)
16 .W " - ",$P(SBCT(RTK),U,1) Q
17 F RTK=0:0 S RTK=$O(SUBR(RTK)) Q:RTK'>"" D
18 .S INDT=$P(SUBR(RTK),U,2) D DT
19 .W !?4,EXDT," - SUBSEQUENT RECURRENCE ",$P(SUBR(RTK),U,3)
20 .W " - ",$P(SUBR(RTK),U,1) Q
21 F RTK=0:0 S RTK=$O(RADT(RTK)) Q:RTK'>"" D
22 .S INDT=$P(RADT(RTK),U,2) D DT
23 .W !?4,EXDT," - RADIATION TREATMENT ",$P(RADT(RTK),U,3)
24 .W " - ",$P(RADT(RTK),U,1) Q
25 W !
26 ;
27KLL I DTXFLAG=1,X<3040000 D
28 .F PIECE=1:1:12 S $P(^ONCO(165.5,D0,"CS"),U,PIECE)=""
29 .F PIECE=1:1:11 S $P(^ONCO(165.5,D0,"CS1"),U,PIECE)=""
30 K C,DTXFLAG,EXDT,FLD,FLDNM,INDT,LIST,MULT,NODE0,NODE1,NODE22
31 K NODE3,NODE31,NODE5,NODE7,NODEBL1,NODEBL2,NODENH2,NODEST2,NODETH1
32 K RADT,RADTZND,RDZ,RTK,SBCT,SBCTZND,SRZ,SUBR,SUBRZND,SZ Q
33 ;
34CHKDTS ; Check it against all other DATE fields
35 S NODE0=$G(^ONCO(165.5,D0,0)),NODE1=$G(^ONCO(165.5,D0,1))
36 S NODE3=$G(^ONCO(165.5,D0,3)),NODE31=$G(^ONCO(165.5,D0,3.1))
37 S NODE5=$G(^ONCO(165.5,D0,5)),NODE7=$G(^ONCO(165.5,D0,7))
38 S NODENH2=$G(^ONCO(165.5,D0,"NHL2")),NODE22=$G(^ONCO(165.5,D0,2.2))
39 S NODEBL1=$G(^ONCO(165.5,D0,"BLA1")),NODEBL2=$G(^ONCO(165.5,D0,"BLA2"))
40 S NODETH1=$G(^ONCO(165.5,D0,"THY1")),NODEST2=$G(^ONCO(165.5,D0,"STS2"))
41 ;
42 S FLD=$P(NODE1,U,10),FLDNM=$P($G(^DD(165.5,17,0)),U,1) D EDCHK
43 S FLD=$P(NODE3,U,1),FLDNM=$P($G(^DD(165.5,50,0)),U,1) D EDCHK
44 S FLD=$P(NODE3,U,4),FLDNM=$P($G(^DD(165.5,51,0)),U,1) D EDCHK
45 S FLD=$P(NODE3,U,11),FLDNM=$P($G(^DD(165.5,53,0)),U,1) D EDCHK
46 S FLD=$P(NODE3,U,14),FLDNM=$P($G(^DD(165.5,54,0)),U,1) D EDCHK
47 S FLD=$P(NODE3,U,17),FLDNM=$P($G(^DD(165.5,55,0)),U,1) D EDCHK
48 S FLD=$P(NODE3,U,23),FLDNM=$P($G(^DD(165.5,57,0)),U,1) D EDCHK
49 S FLD=$P(NODE7,U,9),FLDNM=$P($G(^DD(165.5,64,0)),U,1) D EDCHK
50 S FLD=$P(NODE5,U,1),FLDNM=$P($G(^DD(165.5,70,0)),U,1) D EDCHK
51 S FLD=$P(NODE7,U,1),FLDNM=$P($G(^DD(165.5,90,0)),U,1) D EDCHK
52 S FLD=$P(NODEBL1,U,24),FLDNM=$P($G(^DD(165.5,323,0)),U,1) D EDCHK
53 S FLD=$P(NODEBL2,U,16),FLDNM=$P($G(^DD(165.5,361,0)),U,1) D EDCHK
54 S FLD=$P(NODEBL2,U,22),FLDNM=$P($G(^DD(165.5,367,0)),U,1) D EDCHK
55 S FLD=$P(NODETH1,U,36),FLDNM=$P($G(^DD(165.5,435,0)),U,1) D EDCHK
56 S FLD=$P(NODEST2,U,12),FLDNM=$P($G(^DD(165.5,541,0)),U,1) D EDCHK
57 S FLD=$P(NODEST2,U,38),FLDNM=$P($G(^DD(165.5,567,0)),U,1) D EDCHK
58 S FLD=$P(NODENH2,U,20),FLDNM=$P($G(^DD(165.5,865,0)),U,1) D EDCHK
59 F SBCT=0:0 S SBCT=$O(^ONCO(165.5,D0,4,SBCT)) Q:SBCT'>0 D
60 .S SBCTZND=$G(^ONCO(165.5,D0,4,SBCT,0)),SZ=SBCTZND,MULT="SCT"
61 .S FLD=$P(SZ,U,1),FLDNM=$P($G(^DD(165.51,.01,0)),U,1) D EDCHK
62 .S FLD=$P(SZ,U,11),FLDNM=$P($G(^DD(165.51,.041,0)),U,1) D EDCHK
63 .S FLD=$P(SZ,U,12),FLDNM=$P($G(^DD(165.51,.051,0)),U,1) D EDCHK
64 .S FLD=$P(SZ,U,13),FLDNM=$P($G(^DD(165.51,.061,0)),U,1) D EDCHK
65 .S FLD=$P(SZ,U,14),FLDNM=$P($G(^DD(165.51,.071,0)),U,1) D EDCHK
66 .S FLD=$P(SZ,U,15),FLDNM=$P($G(^DD(165.51,.081,0)),U,1) D EDCHK
67 .S FLD=$P(SZ,U,16),FLDNM=$P($G(^DD(165.51,.091,0)),U,1) D EDCHK
68 F SUBR=0:0 S SUBR=$O(^ONCO(165.5,D0,23,SUBR)) Q:SUBR'>0 D
69 .S SUBRZND=$G(^ONCO(165.5,D0,23,SUBR,0)),SRZ=SUBRZND,MULT="SR"
70 .S FLD=$P(SRZ,U,1),FLDNM=$P($G(^DD(165.572,.01,0)),U,1) D EDCHK
71 Q
72 ;
73EDCHK ; If its a legitimate date check it against the date entered for DT DX
74 ; If its a partial date (no month or no day) just check year or year/mo
75 I FLD=""!(FLD="0000000")!(FLD=9999999) Q
76 I $E(FLD,4,7)="0000" D Q ;no DAY or MONTH
77 .I $E(X,1,3)>$E(FLD,1,3) D ERRDATE Q
78 I $E(FLD,6,7)="00" D Q ;MONTH but no DAY
79 .I $E(X,1,5)>$E(FLD,1,5) D ERRDATE Q
80 I X>FLD D ERRDATE Q
81 Q
82 ;
83ERRDATE ; Set DTXFLAG=0 and add FLDNM to the LIST of fields it must be before
84 S DTXFLAG=0,C=C+1
85 I MULT="SCT" S SBCT(C)=FLDNM_U_FLD_U_SBCT Q
86 I MULT="SR" S SUBR(C)=FLDNM_U_FLD_U_SUBR Q
87 I MULT="RDT" S RADT(C)=FLDNM_U_FLD_U_RADT Q
88 S LIST(C)=FLDNM_U_FLD
89 Q
90 ;
91DT ; CHANGE INTERNAL DATE TO EXTERNAL DATE FORMAT
92 S EXDT=$E(INDT,4,5)_"/"_$E(INDT,6,7)_"/"_($E(INDT,1,3)+1700)
93 Q
Note: See TracBrowser for help on using the repository browser.