source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL19B.m@ 1806

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1RAUTL19B ;HISC/SWM-Utility Routine ;10/29/97 09:29
2 ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
3 ;
4CKREQD(A) ;once a REQ'D fld is "Y", all higher status's same REQ'D fld must be "Y"
5 N E,J,I,P,N,RA1,RASTNAM,RAER1,RAFLG,RAFLDNM,S,ARE
6 ; RAERR is used by RAUTL19 to signal one or more errors
7 S E=0,N=0
8 ; E = order # of status progression
9 ; I = ien of ^RA(72,)
10 ; J = .1 or .5
11 ; P = valid piece number from dd
12 ; store .1 and .5 nodes for each given order # E
13 F S E=$O(^RA(72,"AA",A,E)) Q:E'>0 D
14 . S I=$O(^RA(72,"AA",A,E,0)) Q:'I S RA1(E,.1)=$S($G(^RA(72,I,.1))]"":^(.1),1:"")_"^/"_I,RA1(E,.5)=$S($G(^(.5))]"":^(.5),1:"")_"^/"_I
15 . Q
16 ; if a req'd fld = 'Y', then all higher statuses' same req'd fld = 'Y'
17 ; raflg: 1 = a Yes has has been found on a status level for a field
18 F J=.1,.5 S P=0 D
19 . F S P=$O(^DD(72,"GL",J,P)) Q:P'=+P S E="",RAFLG=0 D
20 .. F S E=$O(RA1(E)) Q:E'=+E D
21 ... I RAFLG=0,$$UP^XLFSTR($P($P(RA1(E,J),"/"),U,P))="Y" S RAFLG=1 Q
22 ... I RAFLG,$$UP^XLFSTR($P($P(RA1(E,J),"/"),U,P))'="Y" S RAER1(J,P,E)=$O(^DD(72,"GL",J,P,0)),N=N+1 ; set error to field number of file 72
23 ... Q
24 .. Q
25 . Q
26PRTREQD ;print any error messages on req'd flds
27 Q:'$O(RAER1(0))
28 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
29 W !!,RADASH,"Checking fields that have 'REQUIRED' in their name",RADASH,!?11,"within : ",A
30 S RAERR=1,S=$S(N>1:"s",1:""),ARE=$S(N>1:"are",1:"is")
31 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
32 W !!?5,"There ",ARE," ",N," error",S," found in REQUIRED fields. The error",S
33 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
34 W !?5,ARE," due to 'Y' being answered at a lower status, and 'N' being"
35 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
36 W !?5,"answered at a higher status for the following prompts"
37 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
38 W !!?5,"PROMPT",?55,"STATUS",?75,"DATA",!,?5,"------",?55,"------",?75,"----"
39 F J=.1,.5 S P=0 D Q:RAOUT
40 . F S P=$O(RAER1(J,P)) Q:P'=+P D Q:RAOUT
41 .. I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
42 .. S RAFLDNM=$O(^DD(72,"GL",J,P,0)),RAFLDNM=$P(^DD(72,RAFLDNM,.1),U) S E=0 W !?5,"'",RAFLDNM,"'"
43 .. F S E=$O(RA1(E)) Q:E'=+E I $G(RA1(E,J))]"" S RASTNAM=$P(^RA(72,$P(RA1(E,J),"/",2),0),U) W ?50,"(",E,")",?55,$E(RASTNAM,1,20),?77,$P($P(RA1(E,J),"/"),U,P),!
44 .. Q
45 . Q
46 I 'RAOUT,$Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
47 W !!?5,"Once a data item is required, it should be required at all higher statuses."
48 Q
49CKCOMP(A) ; check COMPLETE status' reqd field not asked at COMPLETE
50 ; and field is asked at status where it's not reqd
51 N E,RA1,RA2,RA3,I,N,P
52 ; RA2() stores not-required-but-aksed fields
53 ; RA3() stores required-but-not-asked fields, COMPLETE status only
54 S E=0
55CK2 S E=$O(^RA(72,"AA",A,E)) G:E'>0 CK9
56 S I=$O(^RA(72,"AA",A,E,0)) G:'I CK2
57 F N=.1,.2,.5,.6 S RA1(E,N)=$S($G(^RA(72,I,N))]"":^(N),1:"")
58 ; .1 and .2 nodes
59 F P=1,2,4,5,6,13,14 D
60 . I $$UP^XLFSTR($P(RA1(E,.1),U,P))'="Y",$$UP^XLFSTR($P(RA1(E,.2),U,P))="Y" S RA2(E,.1,P)=I_U_$P(RA1(E,.1),U,P)_U_$P(RA1(E,.2),U,P) ; not req'd but asked
61 . I E=9,$$UP^XLFSTR($P(RA1(E,.1),U,P))="Y",$$UP^XLFSTR($P(RA1(E,.2),U,P))'="Y" S RA3(.1,P)=I_U_$P(RA1(E,.1),U,P)_U_$P(RA1(E,.2),U,P) ; req'd but not asked, COMPLETE status only
62 ; .5 and .6 nodes
63 F P=1,3,4,5,8,9 D
64 . I $$UP^XLFSTR($P(RA1(E,.5),U,P))'="Y",$$UP^XLFSTR($P(RA1(E,.6),U,P))="Y" S RA2(E,.5,P)=I_U_$P(RA1(E,.5),U,P)_U_$P(RA1(E,.6),U,P) ; not req'd but asked
65 . I E=9,$$UP^XLFSTR($P(RA1(E,.5),U,P))="Y",$$UP^XLFSTR($P(RA1(E,.6),U,P))'="Y" S RA3(.5,P)=I_U_$P(RA1(E,.5),U,P)_U_$P(RA1(E,.6),U,P) ; req'd but not asked, COMPLETE status only
66 G CK2
67CK9 Q:'$D(RA2) ; there's no NOT-REQUIRED-BUT-ASKED FIELD(S) AT ANY STATUS
68 Q:'$D(RA3) ; there's no REQ'D-BUT-NOT-ASKED FIELDS AT COMPLETE
69 W !!,RADASH,"Warning on reaching Complete",RADASH,!?11,"within : ",A,!
70 W !?5,"The following are permissible, but could lead to failure to"
71 W !?5,"complete cases when prompts are not answered in lower status(es)."
72 W !!?5,"STATUS",?20,"PROMPT",?70,"DATA",!?5,"------",?20,"------",?70,"------"
73 G:'$D(RA2) CKWR7 S E=0
74CKWR1 S E=$O(RA2(E)) G:'E CKWR7 S I=0
75CKWR2 S I=$O(RA2(E,I)) G:'I CKWR1 S P=0
76CKWR3 S P=$O(RA2(E,I,P)) G:'P CKWR2
77 G:'$D(RA3(I,P)) CKWR3 ; skip if there's no problem with COMPLETE's
78 S N=$O(^DD(72,"GL",I+.1,P,0)),N=$P(^DD(72,N,0),U)
79 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
80 W !?5,$P(^RA(72,+RA2(E,I,P),0),U),?20,N,?70,$P(RA2(E,I,P),U,3)
81 S N=$O(^DD(72,"GL",I,P,0)),N=$P(^DD(72,N,0),U)
82 W !?20,N,?70,$P(RA2(E,I,P),U,2),!
83 G CKWR3
84CKWR7 Q:'$D(RA3) S I=0
85CKWR8 S I=$O(RA3(I)) Q:'I S P=0
86CKWR9 S P=$O(RA3(I,P)) G:'P CKWR8
87 S N=$O(^DD(72,"GL",I+.1,P,0)),N=$P(^DD(72,N,0),U)
88 I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
89 W !?5,$P(^RA(72,+RA3(I,P),0),U),?20,N,?70,$P(RA3(I,P),U,3)
90 S N=$O(^DD(72,"GL",I,P,0)),N=$P(^DD(72,N,0),U)
91 W !?20,N,?70,$P(RA3(I,P),U,2),!
92 G CKWR9
Note: See TracBrowser for help on using the repository browser.