DGPTFVC3.m

DGPTFVC3 ;ALB/MTC - VAILIDATION CHECK FOR PTF ADDITIONAL QUESTIONS ; 18 MAR 91

 ;;5.3;Registration;**164,729,1015**;Aug 13, 1993;Build 21

 ;

 ; Called by Q+2^DGPTFTR

 ; Variable Passed In:  PTF - Current PTF record.

 ; Variable Returned :  DGERR - 1 if fails else "" 

 ;

EN ;

 D INIT G:DGOUT ENQ

 D 401,501,701

ENQ ;

 K DGPTF,DGHOLD,DGMOV,DGJ,DGBPC,DGPTIT,DGOUT,DGSUR,DGREC

 Q

501 ;-- check 501's for inconsistent data

 K DGPTIT

 F DGMOV=0:0 S DGMOV=$O(^DGPT(DGPTF,"M",DGMOV)) Q:DGMOV'>0  I $D(^DGPT(DGPTF,"M",DGMOV,0)) S DGHOLD=^(0) D CHKFL5

 K DGMOV

 Q

 ;

CHKFL5 ;-- check field entries

 F DGJ=5:1:9 I $P(DGHOLD,U,DGJ)]"" S DGPTIT($P(DGHOLD,U,DGJ)_";ICD9(")=""

 D DC^DGPTSCAN,SCAN^DGPTSCAN

 I '$D(DGBPC),'$D(^DGPT(DGPTF,"M",DGMOV,300)) G CHK5Q

 S DGHOLD=$S($D(^DGPT(DGPTF,"M",DGMOV,300)):^(300),1:"")

 D GETNUM^DGPTSCAN

 ;F DGII=2:1:DGFNUM I ('$D(DGBPC(DGII))&($P(DGHOLD,U,DGII)]""))!($D(DGBPC(DGII))&($P(DGHOLD,U,DGII)']"")) S DGERR=1 D W501

 F DGII=2:1:DGFNUM I ($D(DGBPC(DGII))&($P(DGHOLD,U,DGII)']"")) S DGERR=1 D W501

 ;

CHK5Q K DGFNUM,DGII,DGBPC,DGPTIT

 Q

 ;

401 ;-- check 401's for inconsistent data

 K DGPTIT

 F DGSUR=0:0 S DGSUR=$O(^DGPT(DGPTF,"S",DGSUR)) Q:DGSUR'>0  I $D(^DGPT(DGPTF,"S",DGSUR,0)) S DGHOLD=^(0) D CHKFL4

 Q

 ;

CHKFL4 ;-- check field entries

 F DGJ=8:1:12 I $P(DGHOLD,U,DGJ)]"" S DGPTIT($P(DGHOLD,U,DGJ)_";ICD0(")=""

 D DC^DGPTSCAN,SCAN^DGPTSCAN

 I '$D(DGBPC),'$D(^DGPT(DGPTF,"S",+DGSUR,300)) G CHK4Q

 S DGHOLD=$S($D(^DGPT(DGPTF,"S",+DGSUR,300)):^(300),1:"")

 ;I ('$D(DGBPC(1))&($P(DGHOLD,U)]""))!($D(DGBPC(1))&($P(DGHOLD,U)']"")) S DGERR=1 D W401

 I ($D(DGBPC(1))&($P(DGHOLD,U)']"")) S DGERR=1 D W401

CHK4Q K DGBPC,DGPTIT

 Q

 ;

701 ;-- process 701 load DGPTIT array

 K DGPTIT

 G CHK7Q:'$D(^DGPT(DGPTF,70)) S DGREC=^(70)

 F DGI=10,16:1:24 I $P(DGREC,U,DGI) S DGPTIT($P(DGREC,U,DGI)_";ICD9(")=""

 D DC^DGPTSCAN,SCAN^DGPTSCAN,ANYPSY^DGPTSCAN

 I '$D(DGBPC),'$D(^DGPT(DGPTF,"M")) G CHK7Q

 S DGTREC=$S($D(^DGPT(DGPTF,300)):^(300),1:"")

 S DG701="" D FLAGCHK^DGPTSCAN

 D GETNUM^DGPTSCAN

 ;F DGII=2:1:DGFNUM I $D(DGBPC(DGII))&($P(DGTREC,U,DGII)']"")!('$D(DGBPC(DGII))&($P(DG701,U,DGII)]"")&($P(DGTREC,U,DGII)']""))!('$D(DGBPC(DGII))&($P(DGTREC,U,DGII)]"")&($P(DG701,U,DGII)']"")) S DGERR=1 D W701

 F DGII=2:1:DGFNUM I $D(DGBPC(DGII))&($P(DGTREC,U,DGII)']"") S DGERR=1 D W701

CHK7Q ;

 K DGII,DGFNUM,DG701,DGHOLD,DGTREC,DGI

 Q

 ;

W401 ;-- display error message for 401

 N X S X=+^DGPT(DGPTF,"S",DGSUR,0),X=$TR($$FMTE^XLFDT(X,"5DF")," ","0")

 W !,"401 Surgery  date: ",X,"...",$P($T(ERRMSG+1),";",4)

 Q

W501 ;-- display error message for 501

 N X S X=+$P(^DGPT(DGPTF,"M",DGMOV,0),"^",10),X=$TR($$FMTE^XLFDT(X,"5DF")," ","0")

 W !,"501 Movement date: ",X,"...",$P($T(ERRMSG+DGII),";",4)

 Q

W701 ;-- display error messages for 701

 W !,"701 ",$P($T(ERRMSG+DGII),";",4)

 Q

INIT ;

 I '$D(PTF) S DGOUT=1 G INITQ

 S DGOUT=0,DGPTF=PTF

 I '$D(^DGPT(DGPTF)) S (DGOUT,DGERR)=1

 D LO^DGUTL,HOME^%ZIS

INITQ Q

 ;

ERRMSG ;-- error messages

 ;;1;Kidney Transplant Status Data Error.

 ;;2;Suicide Indicator Data Error.

 ;;3;Legionnaire's Disease Indicator Data Error.

 ;;4;Substance Abuse Type Data Error.

 ;;5;Psychiatry Axis IV Data Error.

 ;;6;Psychiatry Axis V Data Error.

 ;;7;Psychiatry Axis V Data Error.

 ;

 ;

DGPTFVC3  ;ALB/MTC - VAILIDATION CHECK FOR PTF ADDITIONAL QUESTIONS ; 18 MAR 91

 +1       ;;5.3;Registration;**164,729,1015**;Aug 13, 1993;Build 21

 +2       ;

 +3       ; Called by Q+2^DGPTFTR

 +4       ; Variable Passed In:  PTF - Current PTF record.

 +5       ; Variable Returned :  DGERR - 1 if fails else "" 

 +6       ;

EN        ;

 +1        DO INIT

           IF DGOUT

               GOTO ENQ

 +2        DO 401

           DO 501

           DO 701

ENQ       ;

 +1        KILL DGPTF,DGHOLD,DGMOV,DGJ,DGBPC,DGPTIT,DGOUT,DGSUR,DGREC

 +2        QUIT 

501       ;-- check 501's for inconsistent data

 +1        KILL DGPTIT

 +2        FOR DGMOV=0:0

               SET DGMOV=$ORDER(^DGPT(DGPTF,"M",DGMOV))

               IF DGMOV'>0

                   QUIT 

               IF $DATA(^DGPT(DGPTF,"M",DGMOV,0))

                   SET DGHOLD=^(0)

                   DO CHKFL5

 +3        KILL DGMOV

 +4        QUIT 

 +5       ;

CHKFL5    ;-- check field entries

 +1        FOR DGJ=5:1:9

               IF $PIECE(DGHOLD,U,DGJ)]""

                   SET DGPTIT($PIECE(DGHOLD,U,DGJ)_";ICD9(")=""

 +2        DO DC^DGPTSCAN

           DO SCAN^DGPTSCAN

 +3        IF '$DATA(DGBPC)

               IF '$DATA(^DGPT(DGPTF,"M",DGMOV,300))

                   GOTO CHK5Q

 +4        SET DGHOLD=$SELECT($DATA(^DGPT(DGPTF,"M",DGMOV,300)):^(300),1:"")

 +5        DO GETNUM^DGPTSCAN

 +6       ;F DGII=2:1:DGFNUM I ('$D(DGBPC(DGII))&($P(DGHOLD,U,DGII)]""))!($D(DGBPC(DGII))&($P(DGHOLD,U,DGII)']"")) S DGERR=1 D W501

 +7        FOR DGII=2:1:DGFNUM

               IF ($DATA(DGBPC(DGII))&($PIECE(DGHOLD,U,DGII)']""))

                   SET DGERR=1

                   DO W501

 +8       ;

CHK5Q      KILL DGFNUM,DGII,DGBPC,DGPTIT

 +1        QUIT 

 +2       ;

401       ;-- check 401's for inconsistent data

 +1        KILL DGPTIT

 +2        FOR DGSUR=0:0

               SET DGSUR=$ORDER(^DGPT(DGPTF,"S",DGSUR))

               IF DGSUR'>0

                   QUIT 

               IF $DATA(^DGPT(DGPTF,"S",DGSUR,0))

                   SET DGHOLD=^(0)

                   DO CHKFL4

 +3        QUIT 

 +4       ;

CHKFL4    ;-- check field entries

 +1        FOR DGJ=8:1:12

               IF $PIECE(DGHOLD,U,DGJ)]""

                   SET DGPTIT($PIECE(DGHOLD,U,DGJ)_";ICD0(")=""

 +2        DO DC^DGPTSCAN

           DO SCAN^DGPTSCAN

 +3        IF '$DATA(DGBPC)

               IF '$DATA(^DGPT(DGPTF,"S",+DGSUR,300))

                   GOTO CHK4Q

 +4        SET DGHOLD=$SELECT($DATA(^DGPT(DGPTF,"S",+DGSUR,300)):^(300),1:"")

 +5       ;I ('$D(DGBPC(1))&($P(DGHOLD,U)]""))!($D(DGBPC(1))&($P(DGHOLD,U)']"")) S DGERR=1 D W401

 +6        IF ($DATA(DGBPC(1))&($PIECE(DGHOLD,U)']""))

               SET DGERR=1

               DO W401

CHK4Q      KILL DGBPC,DGPTIT

 +1        QUIT 

 +2       ;

701       ;-- process 701 load DGPTIT array

 +1        KILL DGPTIT

 +2        IF '$DATA(^DGPT(DGPTF,70))

               GOTO CHK7Q

           SET DGREC=^(70)

 +3        FOR DGI=10,16:1:24

               IF $PIECE(DGREC,U,DGI)

                   SET DGPTIT($PIECE(DGREC,U,DGI)_";ICD9(")=""

 +4        DO DC^DGPTSCAN

           DO SCAN^DGPTSCAN

           DO ANYPSY^DGPTSCAN

 +5        IF '$DATA(DGBPC)

               IF '$DATA(^DGPT(DGPTF,"M"))

                   GOTO CHK7Q

 +6        SET DGTREC=$SELECT($DATA(^DGPT(DGPTF,300)):^(300),1:"")

 +7        SET DG701=""

           DO FLAGCHK^DGPTSCAN

 +8        DO GETNUM^DGPTSCAN

 +9       ;F DGII=2:1:DGFNUM I $D(DGBPC(DGII))&($P(DGTREC,U,DGII)']"")!('$D(DGBPC(DGII))&($P(DG701,U,DGII)]"")&($P(DGTREC,U,DGII)']""))!('$D(DGBPC(DGII))&($P(DGTREC,U,DGII)]"")&($P(DG701,U,DGII)']"")) S DGERR=1 D W701

 +10       FOR DGII=2:1:DGFNUM

               IF $DATA(DGBPC(DGII))&($PIECE(DGTREC,U,DGII)']"")

                   SET DGERR=1

                   DO W701

CHK7Q     ;

 +1        KILL DGII,DGFNUM,DG701,DGHOLD,DGTREC,DGI

 +2        QUIT 

 +3       ;

W401      ;-- display error message for 401

 +1        NEW X

           SET X=+^DGPT(DGPTF,"S",DGSUR,0)

           SET X=$TRANSLATE($$FMTE^XLFDT(X,"5DF")," ","0")

 +2        WRITE !,"401 Surgery  date: ",X,"...",$PIECE($TEXT(ERRMSG+1),";",4)

 +3        QUIT 

W501      ;-- display error message for 501

 +1        NEW X

           SET X=+$PIECE(^DGPT(DGPTF,"M",DGMOV,0),"^",10)

           SET X=$TRANSLATE($$FMTE^XLFDT(X,"5DF")," ","0")

 +2        WRITE !,"501 Movement date: ",X,"...",$PIECE($TEXT(ERRMSG+DGII),";",4)

 +3        QUIT 

W701      ;-- display error messages for 701

 +1        WRITE !,"701 ",$PIECE($TEXT(ERRMSG+DGII),";",4)

 +2        QUIT 

INIT      ;

 +1        IF '$DATA(PTF)

               SET DGOUT=1

               GOTO INITQ

 +2        SET DGOUT=0

           SET DGPTF=PTF

 +3        IF '$DATA(^DGPT(DGPTF))

               SET (DGOUT,DGERR)=1

 +4        DO LO^DGUTL

           DO HOME^%ZIS

INITQ      QUIT 

 +1       ;

ERRMSG    ;-- error messages

 +1       ;;1;Kidney Transplant Status Data Error.

 +2       ;;2;Suicide Indicator Data Error.

 +3       ;;3;Legionnaire's Disease Indicator Data Error.

 +4       ;;4;Substance Abuse Type Data Error.

 +5       ;;5;Psychiatry Axis IV Data Error.

 +6       ;;6;Psychiatry Axis V Data Error.

 +7       ;;7;Psychiatry Axis V Data Error.

 +8       ;

 +9       ;