- RAUTL19B ;HISC/SWM-Utility Routine ;10/29/97 09:29
- ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
- ;
- CKREQD(A) ;once a REQ'D fld is "Y", all higher status's same REQ'D fld must be "Y"
- N E,J,I,P,N,RA1,RASTNAM,RAER1,RAFLG,RAFLDNM,S,ARE
- ; RAERR is used by RAUTL19 to signal one or more errors
- S E=0,N=0
- ; E = order # of status progression
- ; I = ien of ^RA(72,)
- ; J = .1 or .5
- ; P = valid piece number from dd
- ; store .1 and .5 nodes for each given order # E
- F S E=$O(^RA(72,"AA",A,E)) Q:E'>0 D
- . 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
- . Q
- ; if a req'd fld = 'Y', then all higher statuses' same req'd fld = 'Y'
- ; raflg: 1 = a Yes has has been found on a status level for a field
- F J=.1,.5 S P=0 D
- . F S P=$O(^DD(72,"GL",J,P)) Q:P'=+P S E="",RAFLG=0 D
- .. F S E=$O(RA1(E)) Q:E'=+E D
- ... I RAFLG=0,$$UP^XLFSTR($P($P(RA1(E,J),"/"),U,P))="Y" S RAFLG=1 Q
- ... 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
- ... Q
- .. Q
- . Q
- PRTREQD ;print any error messages on req'd flds
- Q:'$O(RAER1(0))
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W !!,RADASH,"Checking fields that have 'REQUIRED' in their name",RADASH,!?11,"within : ",A
- S RAERR=1,S=$S(N>1:"s",1:""),ARE=$S(N>1:"are",1:"is")
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W !!?5,"There ",ARE," ",N," error",S," found in REQUIRED fields. The error",S
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W !?5,ARE," due to 'Y' being answered at a lower status, and 'N' being"
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W !?5,"answered at a higher status for the following prompts"
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W !!?5,"PROMPT",?55,"STATUS",?75,"DATA",!,?5,"------",?55,"------",?75,"----"
- F J=.1,.5 S P=0 D Q:RAOUT
- . F S P=$O(RAER1(J,P)) Q:P'=+P D Q:RAOUT
- .. I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- .. S RAFLDNM=$O(^DD(72,"GL",J,P,0)),RAFLDNM=$P(^DD(72,RAFLDNM,.1),U) S E=0 W !?5,"'",RAFLDNM,"'"
- .. 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),!
- .. Q
- . Q
- I 'RAOUT,$Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W !!?5,"Once a data item is required, it should be required at all higher statuses."
- Q
- CKCOMP(A) ; check COMPLETE status' reqd field not asked at COMPLETE
- ; and field is asked at status where it's not reqd
- N E,RA1,RA2,RA3,I,N,P
- ; RA2() stores not-required-but-aksed fields
- ; RA3() stores required-but-not-asked fields, COMPLETE status only
- S E=0
- CK2 S E=$O(^RA(72,"AA",A,E)) G:E'>0 CK9
- S I=$O(^RA(72,"AA",A,E,0)) G:'I CK2
- F N=.1,.2,.5,.6 S RA1(E,N)=$S($G(^RA(72,I,N))]"":^(N),1:"")
- ; .1 and .2 nodes
- F P=1,2,4,5,6,13,14 D
- . 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
- . 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
- ; .5 and .6 nodes
- F P=1,3,4,5,8,9 D
- . 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
- . 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
- G CK2
- CK9 Q:'$D(RA2) ; there's no NOT-REQUIRED-BUT-ASKED FIELD(S) AT ANY STATUS
- Q:'$D(RA3) ; there's no REQ'D-BUT-NOT-ASKED FIELDS AT COMPLETE
- W !!,RADASH,"Warning on reaching Complete",RADASH,!?11,"within : ",A,!
- W !?5,"The following are permissible, but could lead to failure to"
- W !?5,"complete cases when prompts are not answered in lower status(es)."
- W !!?5,"STATUS",?20,"PROMPT",?70,"DATA",!?5,"------",?20,"------",?70,"------"
- G:'$D(RA2) CKWR7 S E=0
- CKWR1 S E=$O(RA2(E)) G:'E CKWR7 S I=0
- CKWR2 S I=$O(RA2(E,I)) G:'I CKWR1 S P=0
- CKWR3 S P=$O(RA2(E,I,P)) G:'P CKWR2
- G:'$D(RA3(I,P)) CKWR3 ; skip if there's no problem with COMPLETE's
- S N=$O(^DD(72,"GL",I+.1,P,0)),N=$P(^DD(72,N,0),U)
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W !?5,$P(^RA(72,+RA2(E,I,P),0),U),?20,N,?70,$P(RA2(E,I,P),U,3)
- S N=$O(^DD(72,"GL",I,P,0)),N=$P(^DD(72,N,0),U)
- W !?20,N,?70,$P(RA2(E,I,P),U,2),!
- G CKWR3
- CKWR7 Q:'$D(RA3) S I=0
- CKWR8 S I=$O(RA3(I)) Q:'I S P=0
- CKWR9 S P=$O(RA3(I,P)) G:'P CKWR8
- S N=$O(^DD(72,"GL",I+.1,P,0)),N=$P(^DD(72,N,0),U)
- I $Y>(IOSL-6) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD^RAUTL11
- W !?5,$P(^RA(72,+RA3(I,P),0),U),?20,N,?70,$P(RA3(I,P),U,3)
- S N=$O(^DD(72,"GL",I,P,0)),N=$P(^DD(72,N,0),U)
- W !?20,N,?70,$P(RA3(I,P),U,2),!
- G CKWR9
- RAUTL19B ;HISC/SWM-Utility Routine ;10/29/97 09:29
- +1 ;;5.0;Radiology/Nuclear Medicine;**10**;Mar 16, 1998
- +2 ;
- CKREQD(A) ;once a REQ'D fld is "Y", all higher status's same REQ'D fld must be "Y"
- +1 NEW E,J,I,P,N,RA1,RASTNAM,RAER1,RAFLG,RAFLDNM,S,ARE
- +2 ; RAERR is used by RAUTL19 to signal one or more errors
- +3 SET E=0
- SET N=0
- +4 ; E = order # of status progression
- +5 ; I = ien of ^RA(72,)
- +6 ; J = .1 or .5
- +7 ; P = valid piece number from dd
- +8 ; store .1 and .5 nodes for each given order # E
- +9 FOR
- SET E=$ORDER(^RA(72,"AA",A,E))
- IF E'>0
- QUIT
- Begin DoDot:1
- +10 SET I=$ORDER(^RA(72,"AA",A,E,0))
- IF 'I
- QUIT
- SET RA1(E,.1)=$SELECT($GET(^RA(72,I,.1))]"":^(.1),1:"")_"^/"_I
- SET RA1(E,.5)=$SELECT($GET(^(.5))]"":^(.5),1:"")_"^/"_I
- +11 QUIT
- End DoDot:1
- +12 ; if a req'd fld = 'Y', then all higher statuses' same req'd fld = 'Y'
- +13 ; raflg: 1 = a Yes has has been found on a status level for a field
- +14 FOR J=.1,.5
- SET P=0
- Begin DoDot:1
- +15 FOR
- SET P=$ORDER(^DD(72,"GL",J,P))
- IF P'=+P
- QUIT
- SET E=""
- SET RAFLG=0
- Begin DoDot:2
- +16 FOR
- SET E=$ORDER(RA1(E))
- IF E'=+E
- QUIT
- Begin DoDot:3
- +17 IF RAFLG=0
- IF $$UP^XLFSTR($PIECE($PIECE(RA1(E,J),"/"),U,P))="Y"
- SET RAFLG=1
- QUIT
- +18 ; set error to field number of file 72
- IF RAFLG
- IF $$UP^XLFSTR($PIECE($PIECE(RA1(E,J),"/"),U,P))'="Y"
- SET RAER1(J,P,E)=$ORDER(^DD(72,"GL",J,P,0))
- SET N=N+1
- +19 QUIT
- End DoDot:3
- +20 QUIT
- End DoDot:2
- +21 QUIT
- End DoDot:1
- PRTREQD ;print any error messages on req'd flds
- +1 IF '$ORDER(RAER1(0))
- QUIT
- +2 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +3 WRITE !!,RADASH,"Checking fields that have 'REQUIRED' in their name",RADASH,!?11,"within : ",A
- +4 SET RAERR=1
- SET S=$SELECT(N>1:"s",1:"")
- SET ARE=$SELECT(N>1:"are",1:"is")
- +5 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +6 WRITE !!?5,"There ",ARE," ",N," error",S," found in REQUIRED fields. The error",S
- +7 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +8 WRITE !?5,ARE," due to 'Y' being answered at a lower status, and 'N' being"
- +9 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +10 WRITE !?5,"answered at a higher status for the following prompts"
- +11 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +12 WRITE !!?5,"PROMPT",?55,"STATUS",?75,"DATA",!,?5,"------",?55,"------",?75,"----"
- +13 FOR J=.1,.5
- SET P=0
- Begin DoDot:1
- +14 FOR
- SET P=$ORDER(RAER1(J,P))
- IF P'=+P
- QUIT
- Begin DoDot:2
- +15 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +16 SET RAFLDNM=$ORDER(^DD(72,"GL",J,P,0))
- SET RAFLDNM=$PIECE(^DD(72,RAFLDNM,.1),U)
- SET E=0
- WRITE !?5,"'",RAFLDNM,"'"
- +17 FOR
- SET E=$ORDER(RA1(E))
- IF E'=+E
- QUIT
- IF $GET(RA1(E,J))]""
- SET RASTNAM=$PIECE(^RA(72,$PIECE(RA1(E,J),"/",2),0),U)
- WRITE ?50,"(",E,")",?55,$EXTRACT(RASTNAM,1,20),?77,$PIECE($PIECE(RA1(E,J),"/"),U,P),!
- +18 QUIT
- End DoDot:2
- IF RAOUT
- QUIT
- +19 QUIT
- End DoDot:1
- IF RAOUT
- QUIT
- +20 IF 'RAOUT
- IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +21 WRITE !!?5,"Once a data item is required, it should be required at all higher statuses."
- +22 QUIT
- CKCOMP(A) ; check COMPLETE status' reqd field not asked at COMPLETE
- +1 ; and field is asked at status where it's not reqd
- +2 NEW E,RA1,RA2,RA3,I,N,P
- +3 ; RA2() stores not-required-but-aksed fields
- +4 ; RA3() stores required-but-not-asked fields, COMPLETE status only
- +5 SET E=0
- CK2 SET E=$ORDER(^RA(72,"AA",A,E))
- IF E'>0
- GOTO CK9
- +1 SET I=$ORDER(^RA(72,"AA",A,E,0))
- IF 'I
- GOTO CK2
- +2 FOR N=.1,.2,.5,.6
- SET RA1(E,N)=$SELECT($GET(^RA(72,I,N))]"":^(N),1:"")
- +3 ; .1 and .2 nodes
- +4 FOR P=1,2,4,5,6,13,14
- Begin DoDot:1
- +5 ; not req'd but asked
- IF $$UP^XLFSTR($PIECE(RA1(E,.1),U,P))'="Y"
- IF $$UP^XLFSTR($PIECE(RA1(E,.2),U,P))="Y"
- SET RA2(E,.1,P)=I_U_$PIECE(RA1(E,.1),U,P)_U_$PIECE(RA1(E,.2),U,P)
- +6 ; req'd but not asked, COMPLETE status only
- IF E=9
- IF $$UP^XLFSTR($PIECE(RA1(E,.1),U,P))="Y"
- IF $$UP^XLFSTR($PIECE(RA1(E,.2),U,P))'="Y"
- SET RA3(.1,P)=I_U_$PIECE(RA1(E,.1),U,P)_U_$PIECE(RA1(E,.2),U,P)
- End DoDot:1
- +7 ; .5 and .6 nodes
- +8 FOR P=1,3,4,5,8,9
- Begin DoDot:1
- +9 ; not req'd but asked
- IF $$UP^XLFSTR($PIECE(RA1(E,.5),U,P))'="Y"
- IF $$UP^XLFSTR($PIECE(RA1(E,.6),U,P))="Y"
- SET RA2(E,.5,P)=I_U_$PIECE(RA1(E,.5),U,P)_U_$PIECE(RA1(E,.6),U,P)
- +10 ; req'd but not asked, COMPLETE status only
- IF E=9
- IF $$UP^XLFSTR($PIECE(RA1(E,.5),U,P))="Y"
- IF $$UP^XLFSTR($PIECE(RA1(E,.6),U,P))'="Y"
- SET RA3(.5,P)=I_U_$PIECE(RA1(E,.5),U,P)_U_$PIECE(RA1(E,.6),U,P)
- End DoDot:1
- +11 GOTO CK2
- CK9 ; there's no NOT-REQUIRED-BUT-ASKED FIELD(S) AT ANY STATUS
- IF '$DATA(RA2)
- QUIT
- +1 ; there's no REQ'D-BUT-NOT-ASKED FIELDS AT COMPLETE
- IF '$DATA(RA3)
- QUIT
- +2 WRITE !!,RADASH,"Warning on reaching Complete",RADASH,!?11,"within : ",A,!
- +3 WRITE !?5,"The following are permissible, but could lead to failure to"
- +4 WRITE !?5,"complete cases when prompts are not answered in lower status(es)."
- +5 WRITE !!?5,"STATUS",?20,"PROMPT",?70,"DATA",!?5,"------",?20,"------",?70,"------"
- +6 IF '$DATA(RA2)
- GOTO CKWR7
- SET E=0
- CKWR1 SET E=$ORDER(RA2(E))
- IF 'E
- GOTO CKWR7
- SET I=0
- CKWR2 SET I=$ORDER(RA2(E,I))
- IF 'I
- GOTO CKWR1
- SET P=0
- CKWR3 SET P=$ORDER(RA2(E,I,P))
- IF 'P
- GOTO CKWR2
- +1 ; skip if there's no problem with COMPLETE's
- IF '$DATA(RA3(I,P))
- GOTO CKWR3
- +2 SET N=$ORDER(^DD(72,"GL",I+.1,P,0))
- SET N=$PIECE(^DD(72,N,0),U)
- +3 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +4 WRITE !?5,$PIECE(^RA(72,+RA2(E,I,P),0),U),?20,N,?70,$PIECE(RA2(E,I,P),U,3)
- +5 SET N=$ORDER(^DD(72,"GL",I,P,0))
- SET N=$PIECE(^DD(72,N,0),U)
- +6 WRITE !?20,N,?70,$PIECE(RA2(E,I,P),U,2),!
- +7 GOTO CKWR3
- CKWR7 IF '$DATA(RA3)
- QUIT
- SET I=0
- CKWR8 SET I=$ORDER(RA3(I))
- IF 'I
- QUIT
- SET P=0
- CKWR9 SET P=$ORDER(RA3(I,P))
- IF 'P
- GOTO CKWR8
- +1 SET N=$ORDER(^DD(72,"GL",I+.1,P,0))
- SET N=$PIECE(^DD(72,N,0),U)
- +2 IF $Y>(IOSL-6)
- SET RAOUT=$$EOS^RAUTL5()
- IF RAOUT
- QUIT
- DO HEAD^RAUTL11
- +3 WRITE !?5,$PIECE(^RA(72,+RA3(I,P),0),U),?20,N,?70,$PIECE(RA3(I,P),U,3)
- +4 SET N=$ORDER(^DD(72,"GL",I,P,0))
- SET N=$PIECE(^DD(72,N,0),U)
- +5 WRITE !?20,N,?70,$PIECE(RA3(I,P),U,2),!
- +6 GOTO CKWR9
