- DGRPC1 ;ALB/MRL/PJR - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 5/28/04 8:51am
- ;;5.3;PIMS;**314,342,451,564,688,1015,1016**;JUN 30, 2012;Build 20
- 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 S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,+DGLST<41 Q
- I +DGLST,+DGLST<79 S DGLST=DGLST_"^DGRPC2" Q
- S:'DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC3"
- Q
- DGRPC1 ;ALB/MRL/PJR - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 5/28/04 8:51am
- +1 ;;5.3;PIMS;**314,342,451,564,688,1015,1016**;JUN 30, 2012;Build 20
- 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 SET I=$FIND(DGCHK,(","_+DGLST_","))
- SET DGLST=+$EXTRACT(DGCHK,I,999)
- IF +DGLST
- IF +DGLST<41
- QUIT
- +1 IF +DGLST
- IF +DGLST<79
- SET DGLST=DGLST_"^DGRPC2"
- QUIT
- +2 IF 'DGLST
- SET DGLST="END^DGRPC3"
- IF +DGLST
- SET DGLST=DGLST_"^DGRPC3"
- +3 QUIT
