DGRPC1 ;ALB/MRL/PJR - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 5/28/04 8:51am
;;5.3;Registration;**314,342,451,564,688,861**;Aug 13, 1993;Build 29
18 ;
19 S X=$S($P(DGCD,"^",5)="Y":1,1:0) I $S(X=DGVT:0,DGVT=2&('X):0,1:1) S X=$S(DGVT:18,1:19) I DGCHK[(","_X_",") D COMB
S:'DGVT DGLST=$S(+DGLST>22:+DGLST,1:22) G:DGCHK'[",22,"&'DGVT FIND^DGRPC2 D NEXT I DGLST>20!('DGLST) G @DGLST
20 I DGVT,DGSC S DGD=$S(+$P(DGP(.3),"^",2)>49:1,1:3) I $P(DGCD,"^",4)'=DGD!($P(DGCD,"^",5)="N") S X=20 D COMB
S:DGSC DGLST=$S(+DGLST>22:+DGLST,1:22) G:DGCHK'[",22,"&DGSC FIND^DGRPC2 D NEXT I +DGLST'=21 G @DGLST
21 ; off
D NEXT I +DGLST'=22 G @DGLST
22 I $P(DGP("VET"),"^",1)'="Y" G 221
S DGSTR="^"
I DGSC S DGSTR=DGSTR_$S($P(DGP(.3),"^",2)<50:3,1:1)_"^" G 220 ;only appropriate sc type
I $P(DGP(.52),"^",5)="Y" S DGSTR=DGSTR_"18^" G 220 ;pow only
I $P(DGP(.53),"^",1)="Y" S DGSTR=DGSTR_"22^" G 220 ;Purple Heart
I $P(DGP(0),"^",3)'>2061231 S DGSTR=DGSTR_"16^" ;mex border
I $P(DGP(0),"^",3)'>2071231 S DGSTR=DGSTR_"17^" ;allow WWI
S DGFL=0 I $P(DGP(.362),"^",12)="Y" S DGSTR=DGSTR_"2^",DGFL=1 ; a&a
I $P(DGP(.362),"^",13)="Y" S DGSTR=DGSTR_"15^",DGFL=1 ; hb
I DGFL=1 G 220
I $P(DGP(.362),"^",14)="Y" S DGSTR=DGSTR_"4^" G 220 ;nsc, va pen
S DGSTR=DGSTR_"5^" ;nsc
220 I DGSTR'[("^"_$P(DGCD,"^",9)_"^") S X=22 D COMB
K DGSTR
221 D NEXT I +DGLST'=23 G @DGLST
23 S DGD=$G(^DPT(DFN,.361)) I $P(DGD,"^",1)="V",$P(DGD,"^",2)="" S X=23 D COMB
D NEXT I +DGLST'=24 G @DGLST
24 I '$D(^DIC(21,+$P(DGP(.32),"^",3),"E",+$P(DGP(.36),"^",1))) S X=24 D COMB
D NEXT I +DGLST'=25 G @DGLST
25 ;off
S:DGVT DGLST=35 G:DGCHK'[",35,"&DGVT FIND^DGRPC2 D NEXT I +DGLST'=26 G @DGLST
26 ;off
27 ;off
28 ;off
D NEXT I +DGLST>32!('DGLST) G @DGLST
29 ;
30 ;
31 ;
;
32 I 'DGVT S DGD=DGP(.362),X=28 F I=12,13,14,16 S X=X+1 I $P(DGD,"^",I)="Y",(DGCHK[(","_X_",")) D COMB
S DGLST=32 G:DGCHK'[",32," FIND^DGRPC2 D NEXT G @DGLST
33 ;off
S DGLST=33 G:DGCHK'[",33," FIND^DGRPC2 D NEXT I +DGLST>35!('DGLST) G @DGLST
;
34 I 'DGVT,$P(DGP(.52),"^",5)="Y",DGCHK[(","_34_",") D COMB S DGLST=34 G:DGCHK'[",34," FIND^DGRPC2 D NEXT G @DGLST
35 ;off
S DGLST=35 G:DGCHK'[",35," FIND^DGRPC2 D NEXT I +DGLST'=36 G @DGLST
36 I '$D(^DG(391,+DGP("TYPE"),0)) S X=36 D COMB
;;S:'DGVT DGLST=48 G:DGCHK'[",48,"&'DGVT FIND^DGRPC2 D NEXT I +DGLST>40!('DGLST) G @DGLST
D NEXT I +DGLST>40!('DGLST) G @DGLST
37 ;; This check deactivated by EVC project (DG*5.3*688)
38 ;
39 ;
40 F I=5,11 S I2=0,X=$S(I=5:37,1:39) I $P(DGP(.52),"^",I)="Y" D PC
;;
41 ;; Inconsistencies 41 and 42 are superseded by 72 through 82
42 ;;
;;
S DGLST=42 S:'DGVT DGLST=48 G:DGCHK'[",48,"&'DGVT FIND^DGRPC2 D NEXT G @DGLST
;
PC I DGCHK[(","_X_","),X'=37 F I1=I+1:1:I+3 I $P(DGP(.52),"^",I1)="",'I2 D COMB S I2=1
I DGCHK[(","_X_","),X'=37 F I1=I+2:1:I+3 I $E($P(DGP(.52),"^",I1),4,7)="0000",'I2 D COMB S I2=1
S X=X+1 I DGCHK[(","_X_","),$P(DGP(.52),"^",I+2),$P(DGP(.52),"^",I+3),'$$B4^DGRPDT($P(DGP(.52),"^",I+2),$P(DGP(.52),"^",I+3),1) D COMB
Q
;
COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
Q
NEXT ;DG*5.3*861 Process appropriate consistency checks
N DGLSHLD,DGIX,DGI S DGLSHLD=+DGLST S DGI=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,DGI,999) I +DGLST,+DGLST<41 Q
I 'DGLST D
. F DGIX=DGLSHLD:1:99 I DGCHK[(","_DGIX_",") S DGLST=DGIX Q
I +DGLST,+DGLST>42,+DGLST<79 S DGLST=DGLST_"^DGRPC2" Q
I +DGLST,+DGLST'<79 S DGLST=DGLST_"^DGRPC3" Q
S:'DGLST DGLST="END^DGRPC3"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPC1 3473 printed Sep 23, 2025@20:31:46 Page 2
DGRPC1 ;ALB/MRL/PJR - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 5/28/04 8:51am
+1 ;;5.3;Registration;**314,342,451,564,688,861**;Aug 13, 1993;Build 29
18 ;
19 SET X=$SELECT($PIECE(DGCD,"^",5)="Y":1,1:0)
IF $SELECT(X=DGVT:0,DGVT=2&('X):0,1:1)
SET X=$SELECT(DGVT:18,1:19)
IF DGCHK[(","_X_",")
DO COMB
+1 if 'DGVT
SET DGLST=$SELECT(+DGLST>22:+DGLST,1:22)
if DGCHK'[",22,"&'DGVT
GOTO FIND^DGRPC2
DO NEXT
IF DGLST>20!('DGLST)
GOTO @DGLST
20 IF DGVT
IF DGSC
SET DGD=$SELECT(+$PIECE(DGP(.3),"^",2)>49:1,1:3)
IF $PIECE(DGCD,"^",4)'=DGD!($PIECE(DGCD,"^",5)="N")
SET X=20
DO COMB
+1 if DGSC
SET DGLST=$SELECT(+DGLST>22:+DGLST,1:22)
if DGCHK'[",22,"&DGSC
GOTO FIND^DGRPC2
DO NEXT
IF +DGLST'=21
GOTO @DGLST
21 ; off
+1 DO NEXT
IF +DGLST'=22
GOTO @DGLST
22 IF $PIECE(DGP("VET"),"^",1)'="Y"
GOTO 221
+1 SET DGSTR="^"
+2 ;only appropriate sc type
IF DGSC
SET DGSTR=DGSTR_$SELECT($PIECE(DGP(.3),"^",2)<50:3,1:1)_"^"
GOTO 220
+3 ;pow only
IF $PIECE(DGP(.52),"^",5)="Y"
SET DGSTR=DGSTR_"18^"
GOTO 220
+4 ;Purple Heart
IF $PIECE(DGP(.53),"^",1)="Y"
SET DGSTR=DGSTR_"22^"
GOTO 220
+5 ;mex border
IF $PIECE(DGP(0),"^",3)'>2061231
SET DGSTR=DGSTR_"16^"
+6 ;allow WWI
IF $PIECE(DGP(0),"^",3)'>2071231
SET DGSTR=DGSTR_"17^"
+7 ; a&a
SET DGFL=0
IF $PIECE(DGP(.362),"^",12)="Y"
SET DGSTR=DGSTR_"2^"
SET DGFL=1
+8 ; hb
IF $PIECE(DGP(.362),"^",13)="Y"
SET DGSTR=DGSTR_"15^"
SET DGFL=1
+9 IF DGFL=1
GOTO 220
+10 ;nsc, va pen
IF $PIECE(DGP(.362),"^",14)="Y"
SET DGSTR=DGSTR_"4^"
GOTO 220
+11 ;nsc
SET DGSTR=DGSTR_"5^"
220 IF DGSTR'[("^"_$PIECE(DGCD,"^",9)_"^")
SET X=22
DO COMB
+1 KILL DGSTR
221 DO NEXT
IF +DGLST'=23
GOTO @DGLST
23 SET DGD=$GET(^DPT(DFN,.361))
IF $PIECE(DGD,"^",1)="V"
IF $PIECE(DGD,"^",2)=""
SET X=23
DO COMB
+1 DO NEXT
IF +DGLST'=24
GOTO @DGLST
24 IF '$DATA(^DIC(21,+$PIECE(DGP(.32),"^",3),"E",+$PIECE(DGP(.36),"^",1)))
SET X=24
DO COMB
+1 DO NEXT
IF +DGLST'=25
GOTO @DGLST
25 ;off
+1 if DGVT
SET DGLST=35
if DGCHK'[",35,"&DGVT
GOTO FIND^DGRPC2
DO NEXT
IF +DGLST'=26
GOTO @DGLST
26 ;off
27 ;off
28 ;off
+1 DO NEXT
IF +DGLST>32!('DGLST)
GOTO @DGLST
29 ;
30 ;
31 ;
+1 ;
32 IF 'DGVT
SET DGD=DGP(.362)
SET X=28
FOR I=12,13,14,16
SET X=X+1
IF $PIECE(DGD,"^",I)="Y"
IF (DGCHK[(","_X_","))
DO COMB
+1 SET DGLST=32
if DGCHK'[",32,"
GOTO FIND^DGRPC2
DO NEXT
GOTO @DGLST
33 ;off
+1 SET DGLST=33
if DGCHK'[",33,"
GOTO FIND^DGRPC2
DO NEXT
IF +DGLST>35!('DGLST)
GOTO @DGLST
+2 ;
34 IF 'DGVT
IF $PIECE(DGP(.52),"^",5)="Y"
IF DGCHK[(","_34_",")
DO COMB
SET DGLST=34
if DGCHK'[",34,"
GOTO FIND^DGRPC2
DO NEXT
GOTO @DGLST
35 ;off
+1 SET DGLST=35
if DGCHK'[",35,"
GOTO FIND^DGRPC2
DO NEXT
IF +DGLST'=36
GOTO @DGLST
36 IF '$DATA(^DG(391,+DGP("TYPE"),0))
SET X=36
DO COMB
+1 ;;S:'DGVT DGLST=48 G:DGCHK'[",48,"&'DGVT FIND^DGRPC2 D NEXT I +DGLST>40!('DGLST) G @DGLST
+2 DO NEXT
IF +DGLST>40!('DGLST)
GOTO @DGLST
37 ;; This check deactivated by EVC project (DG*5.3*688)
38 ;
39 ;
40 FOR I=5,11
SET I2=0
SET X=$SELECT(I=5:37,1:39)
IF $PIECE(DGP(.52),"^",I)="Y"
DO PC
+1 ;;
41 ;; Inconsistencies 41 and 42 are superseded by 72 through 82
42 ;;
+1 ;;
+2 SET DGLST=42
if 'DGVT
SET DGLST=48
if DGCHK'[",48,"&'DGVT
GOTO FIND^DGRPC2
DO NEXT
GOTO @DGLST
+3 ;
PC IF DGCHK[(","_X_",")
IF X'=37
FOR I1=I+1:1:I+3
IF $PIECE(DGP(.52),"^",I1)=""
IF 'I2
DO COMB
SET I2=1
+1 IF DGCHK[(","_X_",")
IF X'=37
FOR I1=I+2:1:I+3
IF $EXTRACT($PIECE(DGP(.52),"^",I1),4,7)="0000"
IF 'I2
DO COMB
SET I2=1
+2 SET X=X+1
IF DGCHK[(","_X_",")
IF $PIECE(DGP(.52),"^",I+2)
IF $PIECE(DGP(.52),"^",I+3)
IF '$$B4^DGRPDT($PIECE(DGP(.52),"^",I+2),$PIECE(DGP(.52),"^",I+3),1)
DO COMB
+3 QUIT
+4 ;
COMB SET DGCT=DGCT+1
SET DGER=DGER_X_","
SET DGLST=X
QUIT
+1 QUIT
NEXT ;DG*5.3*861 Process appropriate consistency checks
+1 NEW DGLSHLD,DGIX,DGI
SET DGLSHLD=+DGLST
SET DGI=$FIND(DGCHK,(","_+DGLST_","))
SET DGLST=+$EXTRACT(DGCHK,DGI,999)
IF +DGLST
IF +DGLST<41
QUIT
+2 IF 'DGLST
Begin DoDot:1
+3 FOR DGIX=DGLSHLD:1:99
IF DGCHK[(","_DGIX_",")
SET DGLST=DGIX
QUIT
End DoDot:1
+4 IF +DGLST
IF +DGLST>42
IF +DGLST<79
SET DGLST=DGLST_"^DGRPC2"
QUIT
+5 IF +DGLST
IF +DGLST'<79
SET DGLST=DGLST_"^DGRPC3"
QUIT
+6 if 'DGLST
SET DGLST="END^DGRPC3"
+7 QUIT
