- ACGSINTG ;IHS/OIRM/DSD/THL,AEF - CHECK INTEGRITY OF EACH CIS ENTRY; [ 03/27/2000 2:22 PM ]
- ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
- ;;ROUTINE TO CHECK INTEGRITY BETWEEN VARIOUS FIELDS OF EACH CIS ENTRY
- ;;
- EN S X=0,U="^"
- F S X=$O(^ACGS(X)) Q:'X I $D(^ACGS(X,"DT")),$D(^("DT1")),$D(^("DT2")),$D(^("DT3")) S ACGDT=^("DT"),ACGDT1=^("DT1"),ACGDT2=^("DT2"),ACGDT3=^("DT3") D
- .I $P(ACGDT,U,13)>3,$P(ACGDT3,U,11)'="" W !,X,?10,"SOB" S $P(^ACGS(X,"DT3"),U,11)=""
- .I $P(ACGDT3,U,7)="" W !,X,?10,"CICA" S $P(^ACGS(X,"DT3"),U,7)="A"
- .I $P(ACGDT,U,12)="" D
- ..W !,X,?10,$P(ACGDT,U,12,21)
- ..I $P(ACGDT,U,17)=12 S $P(^ACGS(X,"DT"),U,12)="B" D 20
- ..I $P(ACGDT,U,17)<12 S $P(^ACGS(X,"DT"),U,12)="A" D 20
- .I $P(ACGDT,U,12)="A" D
- ..I $P(ACGDT,U,17)<12,$P(ACGDT,U,19)<60,$P(ACGDT,U,18)'="" W !,X,?10,$P(ACGDT,U,12,21) S $P(^ACGS(X,"DT"),U,18)="" D 20
- ..I $P(ACGDT,U,17)=12,$P(ACGDT,U,19)>59 W !,X,?10,$P(ACGDT,U,12,21) S $P(^ACGS(X,"DT"),U,12)="B" S:$P(ACGDT,U,18)="" $P(^ACGS(X,"DT"),U,18)=81 D 20
- ..I $P(ACGDT,U,17)=12,$P(ACGDT,U,19)=56 W !,X,?10,$P(ACGDT,U,12,21) S $P(^ACGS(X,"DT"),U,17)=1,$P(ACGDT,U,18)=""
- ..I $P(ACGDT,U,17)=12,$P(ACGDT,U,19)'=56,$P(ACGDT,U,19)<60 W !,X,?10,$P(ACGDT,U,12,21) S $P(^ACGS(X,"DT"),U,17)=10,$P(ACGDT,U,18)=""
- .I $P(ACGDT,U,12)'="A" D
- ..I $P(ACGDT,U,17)="" W !,X,?10,$P(ACGDT,U,12,21) S $P(^ACGS(X,"DT"),U,17)=12,$P(ACGDT,U,18)=81,$P(^ACGS(X,"DT3"),U,7)="C" D 20
- ..I $P(ACGDT,U,17)=12 D
- ...I $P(ACGDT,U,18)="" W !,X,?10,$P(ACGDT,U,12,21) S $P(^ACGS(X,"DT"),U,18)=81
- ...I $P(ACGDT,U,20)<4 W !,X,?10,$P(ACGDT,U,12,21) D 20
- .I $P(ACGDT,U,12)="C",$P(ACGDT,U,18)'=71 W !,X,?10,$P(ACGDT,U,12,21) S:$P(ACGDT,U,17)'=12 $P(^ACGS(X,"DT"),U,12)=12 S:$P(ACGDT,U,18)'=71 $P(^ACGS(X,"DT"),U,18)=71 D 20
- .S ACG37=$P(^ACGS(X,"DT2"),U,2) I ACG37["-"!($L(ACG37)>7) D
- ..W !,X,?10,ACG37
- ..I ACG37["-" S ACG37=$P(ACG37,"-",2) S $P(^ACGS(X,"DT2"),U,2)=ACG37
- ..I $L(ACG37)>7,$E(ACG37)?1N S ACG37=$E(ACG37,2,8)
- ..I $L(ACG37)>7,$E(ACG37)="J" S ACG37=$E(ACG37,1,7)
- ..S:"j"=$E(ACG37) ACG37="J"_$E(ACG37,2,8) S $P(^ACGS(X,"DT2"),U,2)=ACG37
- ..W !,X,?10,ACG37
- .I $P(ACGDT3,U,9)=1,$P(ACGDT3,U,10)="" W !,X,?10,ACG37 S $P(^ACGS(X,"DT3"),U,10)=2
- .I $P(ACGDT1,U,5)>100000,$P(ACGDT2,U,10)="" W !,X,?10,"SYN" S $P(^ACGS(X,"DT2"),U,10)=$S($P(^ACGS(X,"DT"),U,18)'=77:1,1:2)
- Q
- 20 S $P(^ACGS(X,"DT"),U,20)=$S($P(^ACGS(X,"DT"),U,12)'="A":4,1:3)
- Q
- ACGSINTG ;IHS/OIRM/DSD/THL,AEF - CHECK INTEGRITY OF EACH CIS ENTRY; [ 03/27/2000 2:22 PM ]
- +1 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
- +2 ;;ROUTINE TO CHECK INTEGRITY BETWEEN VARIOUS FIELDS OF EACH CIS ENTRY
- +3 ;;
- EN SET X=0
- SET U="^"
- +1 FOR
- SET X=$ORDER(^ACGS(X))
- IF 'X
- QUIT
- IF $DATA(^ACGS(X,"DT"))
- IF $DATA(^("DT1"))
- IF $DATA(^("DT2"))
- IF $DATA(^("DT3"))
- SET ACGDT=^("DT")
- SET ACGDT1=^("DT1")
- SET ACGDT2=^("DT2")
- SET ACGDT3=^("DT3")
- Begin DoDot:1
- +2 IF $PIECE(ACGDT,U,13)>3
- IF $PIECE(ACGDT3,U,11)'=""
- WRITE !,X,?10,"SOB"
- SET $PIECE(^ACGS(X,"DT3"),U,11)=""
- +3 IF $PIECE(ACGDT3,U,7)=""
- WRITE !,X,?10,"CICA"
- SET $PIECE(^ACGS(X,"DT3"),U,7)="A"
- +4 IF $PIECE(ACGDT,U,12)=""
- Begin DoDot:2
- +5 WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- +6 IF $PIECE(ACGDT,U,17)=12
- SET $PIECE(^ACGS(X,"DT"),U,12)="B"
- DO 20
- +7 IF $PIECE(ACGDT,U,17)<12
- SET $PIECE(^ACGS(X,"DT"),U,12)="A"
- DO 20
- End DoDot:2
- +8 IF $PIECE(ACGDT,U,12)="A"
- Begin DoDot:2
- +9 IF $PIECE(ACGDT,U,17)<12
- IF $PIECE(ACGDT,U,19)<60
- IF $PIECE(ACGDT,U,18)'=""
- WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- SET $PIECE(^ACGS(X,"DT"),U,18)=""
- DO 20
- +10 IF $PIECE(ACGDT,U,17)=12
- IF $PIECE(ACGDT,U,19)>59
- WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- SET $PIECE(^ACGS(X,"DT"),U,12)="B"
- IF $PIECE(ACGDT,U,18)=""
- SET $PIECE(^ACGS(X,"DT"),U,18)=81
- DO 20
- +11 IF $PIECE(ACGDT,U,17)=12
- IF $PIECE(ACGDT,U,19)=56
- WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- SET $PIECE(^ACGS(X,"DT"),U,17)=1
- SET $PIECE(ACGDT,U,18)=""
- +12 IF $PIECE(ACGDT,U,17)=12
- IF $PIECE(ACGDT,U,19)'=56
- IF $PIECE(ACGDT,U,19)<60
- WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- SET $PIECE(^ACGS(X,"DT"),U,17)=10
- SET $PIECE(ACGDT,U,18)=""
- End DoDot:2
- +13 IF $PIECE(ACGDT,U,12)'="A"
- Begin DoDot:2
- +14 IF $PIECE(ACGDT,U,17)=""
- WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- SET $PIECE(^ACGS(X,"DT"),U,17)=12
- SET $PIECE(ACGDT,U,18)=81
- SET $PIECE(^ACGS(X,"DT3"),U,7)="C"
- DO 20
- +15 IF $PIECE(ACGDT,U,17)=12
- Begin DoDot:3
- +16 IF $PIECE(ACGDT,U,18)=""
- WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- SET $PIECE(^ACGS(X,"DT"),U,18)=81
- +17 IF $PIECE(ACGDT,U,20)<4
- WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- DO 20
- End DoDot:3
- End DoDot:2
- +18 IF $PIECE(ACGDT,U,12)="C"
- IF $PIECE(ACGDT,U,18)'=71
- WRITE !,X,?10,$PIECE(ACGDT,U,12,21)
- IF $PIECE(ACGDT,U,17)'=12
- SET $PIECE(^ACGS(X,"DT"),U,12)=12
- IF $PIECE(ACGDT,U,18)'=71
- SET $PIECE(^ACGS(X,"DT"),U,18)=71
- DO 20
- +19 SET ACG37=$PIECE(^ACGS(X,"DT2"),U,2)
- IF ACG37["-"!($LENGTH(ACG37)>7)
- Begin DoDot:2
- +20 WRITE !,X,?10,ACG37
- +21 IF ACG37["-"
- SET ACG37=$PIECE(ACG37,"-",2)
- SET $PIECE(^ACGS(X,"DT2"),U,2)=ACG37
- +22 IF $LENGTH(ACG37)>7
- IF $EXTRACT(ACG37)?1N
- SET ACG37=$EXTRACT(ACG37,2,8)
- +23 IF $LENGTH(ACG37)>7
- IF $EXTRACT(ACG37)="J"
- SET ACG37=$EXTRACT(ACG37,1,7)
- +24 IF "j"=$EXTRACT(ACG37)
- SET ACG37="J"_$EXTRACT(ACG37,2,8)
- SET $PIECE(^ACGS(X,"DT2"),U,2)=ACG37
- +25 WRITE !,X,?10,ACG37
- End DoDot:2
- +26 IF $PIECE(ACGDT3,U,9)=1
- IF $PIECE(ACGDT3,U,10)=""
- WRITE !,X,?10,ACG37
- SET $PIECE(^ACGS(X,"DT3"),U,10)=2
- +27 IF $PIECE(ACGDT1,U,5)>100000
- IF $PIECE(ACGDT2,U,10)=""
- WRITE !,X,?10,"SYN"
- SET $PIECE(^ACGS(X,"DT2"),U,10)=$SELECT($PIECE(^ACGS(X,"DT"),U,18)'=77:1,1:2)
- End DoDot:1
- +28 QUIT
- 20 SET $PIECE(^ACGS(X,"DT"),U,20)=$SELECT($PIECE(^ACGS(X,"DT"),U,12)'="A":4,1:3)
- +1 QUIT
