DGPTFVC3 ;ALB/MTC,HIOFO/FT - VAILIDATION CHECK FOR PTF ADDITIONAL QUESTIONS ;10/21/14 1:59pm
;;5.3;Registration;**164,729,884**;Aug 13, 1993;Build 31
;
; %ZIS APIs - 10086
; XLFDT APIs - 10103
;
; 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=$$STR501^DGPTFUT(DGPTF,DGMOV) D CHKFL5
K DGMOV
Q
;
CHKFL5 ;-- check field entries
F DGJ=1:1:25 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=$$STR401^DGPTFUT(DGPTF,DGSUR) D CHKFL4
Q
;
CHKFL4 ;-- check field entries
F DGJ=1:1:25 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=$$STR701^DGPTFUT(DGPTF)
F DGI=1:1:25 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.
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFVC3 3436 printed Sep 23, 2025@20:28:37 Page 2
DGPTFVC3 ;ALB/MTC,HIOFO/FT - VAILIDATION CHECK FOR PTF ADDITIONAL QUESTIONS ;10/21/14 1:59pm
+1 ;;5.3;Registration;**164,729,884**;Aug 13, 1993;Build 31
+2 ;
+3 ; %ZIS APIs - 10086
+4 ; XLFDT APIs - 10103
+5 ;
+6 ; Called by Q+2^DGPTFTR
+7 ; Variable Passed In: PTF - Current PTF record.
+8 ; Variable Returned : DGERR - 1 if fails else ""
+9 ;
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=$$STR501^DGPTFUT(DGPTF,DGMOV)
DO CHKFL5
+3 KILL DGMOV
+4 QUIT
+5 ;
CHKFL5 ;-- check field entries
+1 FOR DGJ=1:1:25
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=$$STR401^DGPTFUT(DGPTF,DGSUR)
DO CHKFL4
+3 QUIT
+4 ;
CHKFL4 ;-- check field entries
+1 FOR DGJ=1:1:25
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=$$STR701^DGPTFUT(DGPTF)
+3 FOR DGI=1:1:25
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 ;
