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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL19B 5031 printed Dec 13, 2024@02:40:21 Page 2
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
