IVMZ7CS.m

IVMZ7CS ;ALB/TDM,ERC,ARF - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 8/1/08 1:54pm

 ;;2.0;INCOME VERIFICATION MATCH;**105,132,115,211**;OCT 21,1994;Build 14

 ;

 ; Service Consistency Checks

 ; This routine checks the various elements of service information

 ; prior to building a Z07 record.  Any tests which fail consistency

 ; check will be saved to the ^DGIN(38.6 record for the patient.

 ;

 ; Must be called from entry point

 Q

 ;

EN(DFN,DGP) ; entry point.  Patient DFN is sent from calling routine.

 ; initialize working variables

 N RULE,Y,X,FILERR

 ;

 ; loop through rules in INCONSISTENT DATA ELEMENTS file.

 ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07

 ; CHECKS fields are turned ON.

 ;

 ; ***NOTE loop boundary (501-517) must be changed if rule numbers

 ; are added ***

 F RULE=501:1:517 I $D(^DGIN(38.6,RULE)) D

 . S Y=^DGIN(38.6,RULE,0)

 . I $P(Y,U,6) D @RULE

 I $D(FILERR) M ^TMP($J,DFN)=FILERR

 Q

 ;

501 ; POW STATUS INVALID

 S X=$P(DGP("PAT",.52),U,5) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""

 Q

 ;

502 ; MIL DIS RETIREMENT INVALID

 S X=$P(DGP("PAT",.36),U,12) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""

 Q

 ;

503 ; DISCHARGE DUE TO DISAB INVALID

 S X=$P(DGP("PAT",.36),U,13) I (X'="")&(X'=0)&(X'=1) S FILERR(RULE)=""

 Q

 ;

504 ; AGENT ORANGE EXPOSURE INVALID

 S X=$P(DGP("PAT",.321),U,2) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""

 Q

 ;

505 ; RADIATION EXPOSURE INVALID

 S X=$P(DGP("PAT",.321),U,3) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""

 Q

 ;

506 ; SW ASIA CONDITIONS INVALID (Name changed from Env Con. DG*5.3*688)

 S X=$P(DGP("PAT",.322),U,13) I (X'="")&(X'="Y")&(X'="N")&(X'="U") S FILERR(RULE)=""

 Q

 ;

507 ; RAD EXPOSURE METHOD INVALID

 ;IVM*2.0*211 - No longer checking the rule 507 (Refer to DG*5.3*1090)

 ;I $P(DGP("PAT",.321),U,3)="Y" S X=$P(DGP("PAT",.321),U,12) I X'?1N!(X<2)!(X>10) S FILERR(RULE)=""

 Q

 ;

508 ; MST STATUS INVALID

 S X=$P($G(DGP("MST",0)),U,3) I (X'="")&(X'="Y")&(X'="N")&(X'="D")&(X'="U") S FILERR(RULE)=""

 Q

 ;

509 ; MST STATUS CHANGE DATE MISSING

 S X=$P($G(DGP("MST",0)),U,3) I ((X="Y")!(X="N")!(X="D")!(X="U")),$P(DGP("MST",0),U)<1 S FILERR(RULE)=""

 Q

 ;

510 ; MST STATUS SITE REQUIRED

 S X=$P($G(DGP("MST",0)),U,3) I ((X="Y")!(X="N")!(X="D")!(X="U")),$P(DGP("MST",0),U,6)="" S FILERR(RULE)=""

 Q

 ;

511 ; MST STATUS SITE INVALID

 S X=$P($G(DGP("MST",0)),U,6) I X'="",'$$TF^XUAF4(X) S FILERR(RULE)=""

 Q

 ;

512 ; AO EXPOSURE LOCATION MISSING

 ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule

 Q

 ;

513 ; MS ENTRY DATE REQUIRED

 ; Note: RULE #72 in IVMZ7CR is a duplicate of this rule

 Q

 ;

514 ; MS SEPARATION DATE REQUIRED

 ; Note: RULE #72 in IVMZ7CR is a duplicate of this rule

 Q

 ;

515 ; CONFLICT FROM/TO DATE REQUIRED

 ; Note: RULE #74 in IVMZ7CR is a duplicate of this rule

 Q

 ;

516 ; DOB INVALID-MEXICAN BORDER WAR

 N MBW

 I $D(^DPT(DFN,"E")) D

 . S MBW=$O(^DIC(8,"B","MEXICAN BORDER WAR","")) Q:MBW=""

 . S X=0 F  S X=$O(^DPT(DFN,"E",X)) Q:(X<1)!$D(FILERR(RULE))  D

 . . I $P(^DPT(DFN,"E",X,0),U)=MBW,$P(DGP("PAT",0),U,3)>2061231 S FILERR(RULE)=""

 Q

 ;

517 ; DOB INVALID-WORLD WAR I

 N WWI

 I $D(^DPT(DFN,"E")) D

 . S WWI=$O(^DIC(8,"B","WORLD WAR I","")) Q:WWI=""

 . S X=0 F  S X=$O(^DPT(DFN,"E",X)) Q:(X<1)!$D(FILERR(RULE))  D

 . . I $P(^DPT(DFN,"E",X,0),U)=WWI,$P(DGP("PAT",0),U,3)>2071231 S FILERR(RULE)=""

 Q

YM(X) ; Returns whether date has year & month values: 1=yes, 0=no

 Q ($E(X,1,3)>0)&($E(X,4,5)>0)

 ;

YY(X) ; Returns whether date has year a value: 1=yes, 0=no

 Q ($E(X,1,3)>0)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IVMZ7CS   3644     printed  Mar 13, 2025@21:07:16                                                                                                                                                                                                     Page 2

IVMZ7CS   ;ALB/TDM,ERC,ARF - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 8/1/08 1:54pm

 +1       ;;2.0;INCOME VERIFICATION MATCH;**105,132,115,211**;OCT 21,1994;Build 14

 +2       ;

 +3       ; Service Consistency Checks

 +4       ; This routine checks the various elements of service information

 +5       ; prior to building a Z07 record.  Any tests which fail consistency

 +6       ; check will be saved to the ^DGIN(38.6 record for the patient.

 +7       ;

 +8       ; Must be called from entry point

 +9        QUIT 

 +10      ;

EN(DFN,DGP) ; entry point.  Patient DFN is sent from calling routine.

 +1       ; initialize working variables

 +2        NEW RULE,Y,X,FILERR

 +3       ;

 +4       ; loop through rules in INCONSISTENT DATA ELEMENTS file.

 +5       ; execute only the rules where CHECK/DON'T CHECK and INCLUDE IN Z07

 +6       ; CHECKS fields are turned ON.

 +7       ;

 +8       ; ***NOTE loop boundary (501-517) must be changed if rule numbers

 +9       ; are added ***

 +10       FOR RULE=501:1:517

               IF $DATA(^DGIN(38.6,RULE))

                   Begin DoDot:1

 +11                   SET Y=^DGIN(38.6,RULE,0)

 +12                   IF $PIECE(Y,U,6)

                           DO @RULE

                   End DoDot:1

 +13       IF $DATA(FILERR)

               MERGE ^TMP($JOB,DFN)=FILERR

 +14       QUIT 

 +15      ;

501       ; POW STATUS INVALID

 +1        SET X=$PIECE(DGP("PAT",.52),U,5)

           IF (X'="")&(X'="Y")&(X'="N")&(X'="U")

               SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

502       ; MIL DIS RETIREMENT INVALID

 +1        SET X=$PIECE(DGP("PAT",.36),U,12)

           IF (X'="")&(X'=0)&(X'=1)

               SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

503       ; DISCHARGE DUE TO DISAB INVALID

 +1        SET X=$PIECE(DGP("PAT",.36),U,13)

           IF (X'="")&(X'=0)&(X'=1)

               SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

504       ; AGENT ORANGE EXPOSURE INVALID

 +1        SET X=$PIECE(DGP("PAT",.321),U,2)

           IF (X'="")&(X'="Y")&(X'="N")&(X'="U")

               SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

505       ; RADIATION EXPOSURE INVALID

 +1        SET X=$PIECE(DGP("PAT",.321),U,3)

           IF (X'="")&(X'="Y")&(X'="N")&(X'="U")

               SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

506       ; SW ASIA CONDITIONS INVALID (Name changed from Env Con. DG*5.3*688)

 +1        SET X=$PIECE(DGP("PAT",.322),U,13)

           IF (X'="")&(X'="Y")&(X'="N")&(X'="U")

               SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

507       ; RAD EXPOSURE METHOD INVALID

 +1       ;IVM*2.0*211 - No longer checking the rule 507 (Refer to DG*5.3*1090)

 +2       ;I $P(DGP("PAT",.321),U,3)="Y" S X=$P(DGP("PAT",.321),U,12) I X'?1N!(X<2)!(X>10) S FILERR(RULE)=""

 +3        QUIT 

 +4       ;

508       ; MST STATUS INVALID

 +1        SET X=$PIECE($GET(DGP("MST",0)),U,3)

           IF (X'="")&(X'="Y")&(X'="N")&(X'="D")&(X'="U")

               SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

509       ; MST STATUS CHANGE DATE MISSING

 +1        SET X=$PIECE($GET(DGP("MST",0)),U,3)

           IF ((X="Y")!(X="N")!(X="D")!(X="U"))

               IF $PIECE(DGP("MST",0),U)<1

                   SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

510       ; MST STATUS SITE REQUIRED

 +1        SET X=$PIECE($GET(DGP("MST",0)),U,3)

           IF ((X="Y")!(X="N")!(X="D")!(X="U"))

               IF $PIECE(DGP("MST",0),U,6)=""

                   SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

511       ; MST STATUS SITE INVALID

 +1        SET X=$PIECE($GET(DGP("MST",0)),U,6)

           IF X'=""

               IF '$$TF^XUAF4(X)

                   SET FILERR(RULE)=""

 +2        QUIT 

 +3       ;

512       ; AO EXPOSURE LOCATION MISSING

 +1       ; Note: RULE #60 in IVMZ7CR is a duplicate of this rule

 +2        QUIT 

 +3       ;

513       ; MS ENTRY DATE REQUIRED

 +1       ; Note: RULE #72 in IVMZ7CR is a duplicate of this rule

 +2        QUIT 

 +3       ;

514       ; MS SEPARATION DATE REQUIRED

 +1       ; Note: RULE #72 in IVMZ7CR is a duplicate of this rule

 +2        QUIT 

 +3       ;

515       ; CONFLICT FROM/TO DATE REQUIRED

 +1       ; Note: RULE #74 in IVMZ7CR is a duplicate of this rule

 +2        QUIT 

 +3       ;

516       ; DOB INVALID-MEXICAN BORDER WAR

 +1        NEW MBW

 +2        IF $DATA(^DPT(DFN,"E"))

               Begin DoDot:1

 +3                SET MBW=$ORDER(^DIC(8,"B","MEXICAN BORDER WAR",""))

                   if MBW=""

                       QUIT 

 +4                SET X=0

                   FOR 

                       SET X=$ORDER(^DPT(DFN,"E",X))

                       if (X<1)!$DATA(FILERR(RULE))

                           QUIT 

                       Begin DoDot:2

 +5                        IF $PIECE(^DPT(DFN,"E",X,0),U)=MBW

                               IF $PIECE(DGP("PAT",0),U,3)>2061231

                                   SET FILERR(RULE)=""

                       End DoDot:2

               End DoDot:1

 +6        QUIT 

 +7       ;

517       ; DOB INVALID-WORLD WAR I

 +1        NEW WWI

 +2        IF $DATA(^DPT(DFN,"E"))

               Begin DoDot:1

 +3                SET WWI=$ORDER(^DIC(8,"B","WORLD WAR I",""))

                   if WWI=""

                       QUIT 

 +4                SET X=0

                   FOR 

                       SET X=$ORDER(^DPT(DFN,"E",X))

                       if (X<1)!$DATA(FILERR(RULE))

                           QUIT 

                       Begin DoDot:2

 +5                        IF $PIECE(^DPT(DFN,"E",X,0),U)=WWI

                               IF $PIECE(DGP("PAT",0),U,3)>2071231

                                   SET FILERR(RULE)=""

                       End DoDot:2

               End DoDot:1

 +6        QUIT 

YM(X)     ; Returns whether date has year & month values: 1=yes, 0=no

 +1        QUIT ($EXTRACT(X,1,3)>0)&($EXTRACT(X,4,5)>0)

 +2       ;

YY(X)     ; Returns whether date has year a value: 1=yes, 0=no

 +1        QUIT ($EXTRACT(X,1,3)>0)