IBDFFT1.m

IBDFFT1 ;ALB/MAF - FORMS TRACKING CONTINUED - JUL 6 1995

 ;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;APR 24, 1997

 ;

START ;

 N IBDCNT,IBDCNT1,IBDFTIME

 S (IBDCNT,IBDNKA,IBDCNT1,VALMCNT)=0

 D KILL^VALM10()

 D @(IBDFL)

 N IBDFDV,IBDFCL,IBDNODE,IBDFTMP,IBDFPAT,IBDFPT,IBDFT

 S (IBDFDV,IBDFCL,IBDFPT)=0

 ;

 I $D(VAUTG) D

 .N IBDFGR

 .S IBDFGR=0

 .F IBDFDIV=0:0 S IBDFDV=$O(^TMP("FTRK",$J,IBDFDV)) Q:IBDFDV']""  D:'$D(IBDFDIV(IBDFDV)) HEADER^IBDFFT2 F IBDFGRO=0:0 S IBDFGR=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR)) Q:IBDFGR']""  D

 ..F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL)) Q:IBDFCL']""  D:'$D(IBDFGROP(IBDFDV,IBDFGR)) HEADER2^IBDFFT2 D:'$D(IBDFCLIN(IBDFGR,IBDFCL)) HEADER1^IBDFFT2 D

 ...F IBDFT=0:0 S IBDFT=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT)) Q:'IBDFT  F IBDFPAT=0:0 S IBDFPT=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT)) Q:IBDFPT']""  D

 ....F IBDFIFN=0:0 S IBDFIFN=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN)) Q:'IBDFIFN  S IBDX="" F  S IBDX=$O(^TMP("FTRK",$J,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX)) Q:IBDX=""  S IBDFTMP=^(IBDX) D SETARR

 I '$D(VAUTG) D

 .F IBDFDIV=0:0 S IBDFDV=$O(^TMP("FTRK",$J,IBDFDV)) Q:IBDFDV']""  D:'$D(IBDFDIV(IBDFDV)) HEADER^IBDFFT2 F IBDFCLI=0:0 S IBDFCL=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL)) Q:IBDFCL']""  D:'$D(IBDFCLIN(IBDFDV,IBDFCL)) HEADER1^IBDFFT2 D

 ..F IBDFT=0:0 S IBDFT=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT)) Q:'IBDFT  F IBDFPAT=0:0 S IBDFPT=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT)) Q:IBDFPT']""  D

 ...F IBDFIFN=0:0 S IBDFIFN=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN)) Q:'IBDFIFN  S IBDX="" F  S IBDX=$O(^TMP("FTRK",$J,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX)) Q:IBDX=""  S IBDFTMP=^(IBDX) D SETARR

 I '$D(^TMP("FRM",$J)) D NUL^IBDFFT2

 Q

CLN ;  -- Loop clinics

 N IBDFCLIN

 I VAUTC=1 F IBDFCLIN=0:0 S IBDFCLIN=$O(^SC(IBDFCLIN)) Q:'IBDFCLIN  D CK(IBDFCLIN) I QUIT=1 D BLD

 I VAUTC=0 F IBDFCLIN=0:0 S IBDFCLIN=$O(VAUTC(IBDFCLIN)) Q:'IBDFCLIN  D CK(IBDFCLIN) I QUIT=1 D BLD

 D TRACKING Q

PAT ;  -- Loop patients

 N IBDFCLIN,IBDFPAT

 I VAUTN=1 F IBDFPAT=0:0 S IBDFPAT=$O(^DPT(IBDFPAT)) Q:'IBDFPAT  F IBDFT=IBDFBEG:0 S IBDFT=$O(^DPT(IBDFPAT,"S",IBDFT)) Q:'IBDFT!($P(IBDFT,".",1)>IBDFEND)  I $D(^DPT(IBDFPAT,"S",IBDFT,0)) D SET

 I VAUTN=0 F IBDFPAT=0:0 S IBDFPAT=$O(VAUTN(IBDFPAT)) Q:'IBDFPAT  F IBDFT=IBDFBEG:0 S IBDFT=$O(^DPT(IBDFPAT,"S",IBDFT)) Q:'IBDFT!($P(IBDFT,".",1)>IBDFEND)  I $D(^DPT(IBDFPAT,"S",IBDFT,0)) D SET

 D TRACKING Q

GRP D GRP1^IBDFFT

 N IBDFGRP,IBDFCLIN

 F IBDFGRP=0:0 S IBDFGRP=$O(VAUTG(IBDFGRP)) Q:'IBDFGRP  F IBDFCLIN=0:0 S IBDFCLIN=$O(VAUTG(IBDFGRP,IBDFCLIN)) Q:'IBDFCLIN  D CK(IBDFCLIN) I QUIT=1 D BLD

 D TRACKING Q

 ;

 ;

SET S IBDFCLIN=$P(^DPT(IBDFPAT,"S",IBDFT,0),"^",1) D CK(IBDFCLIN) I QUIT=1 S DFN=IBDFPAT D CK1 Q

 Q

 ;

 ;

CK(XCL) ;  -- Check clinic, division, form

 Q:'$D(^SC(+XCL,0))

 S QUIT=0

 S IBDFNODE=$G(^SC(XCL,0))

 Q:$P(IBDFNODE,"^",3)'="C"

 I $G(VAUTD)=0 I $P(IBDFNODE,"^",15)  Q:'$D(VAUTD($P(IBDFNODE,"^",15)))

 D CHECK^IBDFFT(XCL)

 Q:QUIT=0

 Q

 ;

 ;

BLD ; -- scan appts

 F IBDFT=IBDFBEG:0 S IBDFT=$O(^SC(IBDFCLIN,"S",IBDFT)) Q:'IBDFT!($P(IBDFT,".",1)>IBDFEND)  D

 .F IBDFDA=0:0 S IBDFDA=$O(^SC(IBDFCLIN,"S",IBDFT,1,IBDFDA)) Q:'IBDFDA  I $D(^SC(IBDFCLIN,"S",IBDFT,1,IBDFDA,0)) S IBDFSA=^(0) S DFN=+IBDFSA D CK1

 Q

CK1 ; -- 

 N IBDFXPC,IBDFYPC

 S IBDFXPC=$S($D(VAUTC)!($D(VAUTG)):$P(IBDFNODE,"^",1),1:$P(^DPT(IBDFPAT,0),"^",1))

 S IBDFYPC=$S($D(VAUTC)!($D(VAUTG)):$P(^DPT(DFN,0),"^",1),1:$P(IBDFNODE,"^",1))

 I $D(^IBD(357.96,"APTAP",DFN,IBDFT)) S IBDFIFN=0 F  S IBDFIFN=$O(^IBD(357.96,"APTAP",DFN,IBDFT,IBDFIFN)) Q:'IBDFIFN  I $D(^IBD(357.96,IBDFIFN,0)) D

 .I $D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),$P(^IBD(357.99,IBDFGRP,0),"^",1),IBDFXPC,IBDFT,IBDFYPC,DFN,+IBDFIFN)=IBDFCLIN_"^"_^IBD(357.96,IBDFIFN,0)

 .I '$D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBDFXPC,IBDFT,IBDFYPC,DFN,+IBDFIFN)=IBDFCLIN_"^"_^IBD(357.96,IBDFIFN,0)

 .Q

 E  D

 .I $D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),$P(^IBD(357.99,IBDFGRP,0),"^",1),IBDFXPC,IBDFT,IBDFYPC,DFN,0)=IBDFCLIN_"^^"_DFN_"^"_IBDFT

 .I '$D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBDFXPC,IBDFT,IBDFYPC,DFN,0)=IBDFCLIN_"^^"_DFN_"^"_IBDFT

 Q

 ;

SETARR ;  -- Set up Listman array

 S DFN=$P(IBDFTMP,"^",3)

 I '$D(^TMP("CNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)) D

 .S ^TMP("CNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)="0^0^0^0^0^0^0"

 .I $D(VAUTG) I '$D(^TMP("COUNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)) D

 ..S ^TMP("COUNT",$J,$S(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)=1

 I $D(VAUTG) K IBDFLAG I $D(^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)) I IBDFGR=^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN) D COUNT

 I $D(VAUTG) I '$D(^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)) D COUNT

 I '$D(VAUTG) S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)+1

 S IBDCNT1=IBDCNT1+1

 S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1

 S X=""

 S IBDFVAL=$J(IBDCNT1_")",5)

 S X=$$SETSTR^VALM1(IBDFVAL,X,1,5)

 S IBDFVAL=$P($G(IBDFTMP),"^",2)

 S X=$$SETSTR^VALM1(IBDFVAL,X,7,8)

 S IBDFVAL=$P($G(IBDFTMP),"^",4) I IBDFVAL S DNKA=$$DNKA(DFN,IBDFVAL),IBDFVAL=$P($$FMTE^XLFDT(IBDFVAL,2),":",1,2)

 S X=$$SETSTR^VALM1(IBDFVAL,X,17,14)

 I $D(VAUTC)!($D(VAUTG)) S (IBDFVAL,IBDFN)=$P($G(IBDFTMP),"^",3) I IBDFVAL]"" S IBDFVAL=$P(^DPT(IBDFVAL,0),"^",1)

 I $D(VAUTN) S (IBDFVAL,IBDFN)=$P($G(IBDFTMP),"^",1) I IBDFVAL]"" S IBDFVAL=$P(^SC(IBDFVAL,0),"^",1)

 S X=$$SETSTR^VALM1(IBDFVAL,X,34,15)

 S IBDFVAL=$P($G(IBDFTMP),"^",6)

 I IBDFVAL]"" S IBDFVAL=$E(IBDFVAL,4,5)_"/"_$E(IBDFVAL,6,7)_"/"_$E(IBDFVAL,2,3) I '$D(VAUTG)!($D(VAUTG)&($D(IBDFLAG))) S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",2)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",2))+1

 S X=$$SETSTR^VALM1(IBDFVAL,X,50,8)

 S VAL=$P($G(IBDFTMP),"^",12)

 S IBDFVAL=$P($G(IBDFTMP),"^",7)

 I IBDFVAL]"" S IBDFVAL=$E(IBDFVAL,4,5)_"/"_$E(IBDFVAL,6,7)_"/"_$E(IBDFVAL,2,3) I '$D(VAUTG)!($D(VAUTG)&($D(IBDFLAG))) I VAL=2 S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",3)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",3))+1

 S X=$$SETSTR^VALM1(IBDFVAL,X,61,8)

 N IBDFXX

 S IBDFXX=$S(VAL=3:3,VAL=6:5,1:"")

 I IBDFXX]"" I '$D(VAUTG)!($D(VAUTG)&($D(IBDFLAG))) S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",IBDFXX)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",IBDFXX)+1 S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",6)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",6)+1

 S VAL=$S(DNKA:$P(DNKA,"^",2),VAL=1:"PRINTED",VAL=2:"SCANNED",VAL=3:"SCD/PCE",VAL=4:"SCD w/ER",VAL=5:"DENTRY",VAL=6:"DE to PCE",VAL=7:"DE w/ER",VAL=11:"PEND Pgs",VAL=12:"ER/NOTRN",20:"AVAIL DE",1:"NOT PRNT")

 I DNKA S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",7)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",7))+1

 S X=$$SETSTR^VALM1(VAL,X,72,8)

 S IBDFVAL=$S(DNKA:"",1:$$SCHSTAT^IBDFFT($P(IBDFTMP,"^",3),$P(IBDFTMP,"^",4)))

 S X=$$SETSTR^VALM1(IBDFVAL,X,82,12)

 S IBDFVAL=$S($P(IBDFTMP,"^",14):" Yes",1:" No")

 S X=$$SETSTR^VALM1(IBDFVAL,X,96,6)

 ;

 ;

TMP ; -- Set up TMP Array

 S ^TMP("FRM",$J,IBDCNT,0)=$$LOWER^VALM1(X),^TMP("FRM",$J,"IDX",VALMCNT,IBDCNT1)=""

 S ^TMP("FRMIDX",$J,IBDCNT1)=VALMCNT_"^"_$P(IBDFTMP,"^",2)_"^"_$P(IBDFTMP,"^",3)_"^"_$P(IBDFTMP,"^",4)_"^"_$P(IBDFTMP,"^",6)_"^"_$P(IBDFTMP,"^",7)_"^"_$P(IBDFTMP,"^",12)

 D NOW^%DTC S IBDFTIME=% S X1=$S($P(IBDFTMP,"^",7):$P(IBDFTMP,"^",7),1:IBDFTIME),X2=$P(IBDFTMP,"^",4) D ^%DTC S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",4)=+($P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",4))+X

 Q

COUNT ;

 S ^TMP("COUNT",$J,IBDFCL,IBDFT,IBDFIFN)=IBDFGR,IBDFLAG=1

 S $P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)=$P(^TMP("CNT",$J,IBDFDV,IBDFCL),"^",1)+1

 Q

TRACKING ;  -- loops thru forms tracking file 357.96

 ;     X-reference ^IBD(357.96,"ADATNA", Appt date/time, 1 or 0, IFN).

 ;     1 = forms tracking file entry but no scheduled appt associated

 ;     0 = forms tracking file entry with associated scheduled appt.

 N IBDFCLIN,IBAPPTDT,IBDFPAT,IBDFTRK,IBDFX,IBDFT

 S IBDFX=""

 F IBDFT=IBDFBEG:0 S IBDFT=$O(^IBD(357.96,"ADATNA",IBDFT)) Q:'IBDFT!(IBDFT>IBDFEND)  S IBDFTRK=0 F  S IBDFTRK=$O(^IBD(357.96,"ADATNA",IBDFT,1,IBDFTRK)) Q:'IBDFTRK  D

 .Q:'$G(^IBD(357.96,IBDFTRK,0))

 .S IBDFCLIN=$P(^IBD(357.96,IBDFTRK,0),"^",10)

 .I IBDFCLIN']"" Q

 .S IBDFPAT=$P(^IBD(357.96,IBDFTRK,0),"^",2)

 .D CK(IBDFCLIN) I QUIT=1 D

 ..I $D(VAUTC),VAUTC=0,'$D(VAUTC(IBDFCLIN)) Q

 ..I $D(VAUTN),VAUTN=0,'$D(VAUTN(IBDFPAT)) Q

 ..N IBDFXPC,IBDFYPC

 ..S IBDFXPC=$S($D(VAUTC):$P(IBDFNODE,"^",1),$D(VAUTG):$P(IBDFNODE,"^",1),1:$P(^DPT(IBDFPAT,0),"^",1))

 ..S IBDFYPC=$S($D(VAUTC)!($D(VAUTG)):$P(^DPT(IBDFPAT,0),"^",1),1:$P(IBDFNODE,"^",1))

 ..I '$D(VAUTG) S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBDFXPC,IBDFT,IBDFYPC,IBDFPAT,IBDFTRK)=IBDFCLIN_"^"_^IBD(357.96,IBDFTRK,0)

 ..I $D(VAUTG) D

 ...N IBDFGRP,IBDFCLNN,IBDFCLN,IBDFGR

 ...S (IBDFCLN,IBDFGR)=0

 ...F IBDFGR=0:0 S IBDFGR=$O(VAUTG(IBDFGR)) Q:IBDFGR']""  F IBDFCLN=0:0 S IBDFCLN=$O(VAUTG(IBDFGR,IBDFCLN)) Q:IBDFCLN']""  I IBDFCLN=IBDFCLIN D

 ....N IBX,IBY

 ....S IBX=$P($G(^IBD(357.99,IBDFGR,0)),"^"),IBY=$P($G(^SC(IBDFCLN,0)),"^")

 ....S ^TMP("FTRK",$J,$S($D(^DG(40.8,+$P(IBDFNODE,"^",15),0)):$P(^DG(40.8,$P(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBX,IBY,IBDFT,IBDFYPC,IBDFPAT,IBDFTRK)=IBDFCLIN_"^"_^IBD(357.96,IBDFTRK,0)

 Q

 ;

DNKA(DFN,APPT) ;

 ; -- return did not keep appointment

 N STATUS,DNKA

 S DNKA=0

 S STATUS=$P($G(^DPT(+$G(DFN),"S",+$G(APPT),0)),"^",2)

 I STATUS]"" I "^N^C^NA^CA^PC^PCA^"[STATUS S DNKA=1_"^"_$S(STATUS["N":"NO SHOW",1:"CANCELED")

 Q DNKA

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBDFFT1   9846     printed  Feb 19, 2025@00:18:59                                                                                                                                                                                                     Page 2

IBDFFT1   ;ALB/MAF - FORMS TRACKING CONTINUED - JUL 6 1995

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;APR 24, 1997

 +2       ;

START     ;

 +1        NEW IBDCNT,IBDCNT1,IBDFTIME

 +2        SET (IBDCNT,IBDNKA,IBDCNT1,VALMCNT)=0

 +3        DO KILL^VALM10()

 +4        DO @(IBDFL)

 +5        NEW IBDFDV,IBDFCL,IBDNODE,IBDFTMP,IBDFPAT,IBDFPT,IBDFT

 +6        SET (IBDFDV,IBDFCL,IBDFPT)=0

 +7       ;

 +8        IF $DATA(VAUTG)

               Begin DoDot:1

 +9                NEW IBDFGR

 +10               SET IBDFGR=0

 +11               FOR IBDFDIV=0:0

                       SET IBDFDV=$ORDER(^TMP("FTRK",$JOB,IBDFDV))

                       if IBDFDV']""

                           QUIT 

                       if '$DATA(IBDFDIV(IBDFDV))

                           DO HEADER^IBDFFT2

                       FOR IBDFGRO=0:0

                           SET IBDFGR=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR))

                           if IBDFGR']""

                               QUIT 

                           Begin DoDot:2

 +12                           FOR IBDFCLI=0:0

                                   SET IBDFCL=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL))

                                   if IBDFCL']""

                                       QUIT 

                                   if '$DATA(IBDFGROP(IBDFDV,IBDFGR))

                                       DO HEADER2^IBDFFT2

                                   if '$DATA(IBDFCLIN(IBDFGR,IBDFCL))

                                       DO HEADER1^IBDFFT2

                                   Begin DoDot:3

 +13                                   FOR IBDFT=0:0

                                           SET IBDFT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT))

                                           if 'IBDFT

                                               QUIT 

                                           FOR IBDFPAT=0:0

                                               SET IBDFPT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT))

                                               if IBDFPT']""

                                                   QUIT 

                                               Begin DoDot:4

 +14                                               FOR IBDFIFN=0:0

                                                       SET IBDFIFN=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN))

                                                       if 'IBDFIFN

                                                           QUIT 

                                                       SET IBDX=""

                                                       FOR 

                                                           SET IBDX=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFGR,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX))

                                                           if IBDX=""

                                                               QUIT 

                                                           SET IBDFTMP=^(IBDX)

                                                           DO SETARR

                                               End DoDot:4

                                   End DoDot:3

                           End DoDot:2

               End DoDot:1

 +15       IF '$DATA(VAUTG)

               Begin DoDot:1

 +16               FOR IBDFDIV=0:0

                       SET IBDFDV=$ORDER(^TMP("FTRK",$JOB,IBDFDV))

                       if IBDFDV']""

                           QUIT 

                       if '$DATA(IBDFDIV(IBDFDV))

                           DO HEADER^IBDFFT2

                       FOR IBDFCLI=0:0

                           SET IBDFCL=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL))

                           if IBDFCL']""

                               QUIT 

                           if '$DATA(IBDFCLIN(IBDFDV,IBDFCL))

                               DO HEADER1^IBDFFT2

                           Begin DoDot:2

 +17                           FOR IBDFT=0:0

                                   SET IBDFT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT))

                                   if 'IBDFT

                                       QUIT 

                                   FOR IBDFPAT=0:0

                                       SET IBDFPT=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT))

                                       if IBDFPT']""

                                           QUIT 

                                       Begin DoDot:3

 +18                                       FOR IBDFIFN=0:0

                                               SET IBDFIFN=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN))

                                               if 'IBDFIFN

                                                   QUIT 

                                               SET IBDX=""

                                               FOR 

                                                   SET IBDX=$ORDER(^TMP("FTRK",$JOB,IBDFDV,IBDFCL,IBDFT,IBDFPT,IBDFIFN,IBDX))

                                                   if IBDX=""

                                                       QUIT 

                                                   SET IBDFTMP=^(IBDX)

                                                   DO SETARR

                                       End DoDot:3

                           End DoDot:2

               End DoDot:1

 +19       IF '$DATA(^TMP("FRM",$JOB))

               DO NUL^IBDFFT2

 +20       QUIT 

CLN       ;  -- Loop clinics

 +1        NEW IBDFCLIN

 +2        IF VAUTC=1

               FOR IBDFCLIN=0:0

                   SET IBDFCLIN=$ORDER(^SC(IBDFCLIN))

                   if 'IBDFCLIN

                       QUIT 

                   DO CK(IBDFCLIN)

                   IF QUIT=1

                       DO BLD

 +3        IF VAUTC=0

               FOR IBDFCLIN=0:0

                   SET IBDFCLIN=$ORDER(VAUTC(IBDFCLIN))

                   if 'IBDFCLIN

                       QUIT 

                   DO CK(IBDFCLIN)

                   IF QUIT=1

                       DO BLD

 +4        DO TRACKING

           QUIT 

PAT       ;  -- Loop patients

 +1        NEW IBDFCLIN,IBDFPAT

 +2        IF VAUTN=1

               FOR IBDFPAT=0:0

                   SET IBDFPAT=$ORDER(^DPT(IBDFPAT))

                   if 'IBDFPAT

                       QUIT 

                   FOR IBDFT=IBDFBEG:0

                       SET IBDFT=$ORDER(^DPT(IBDFPAT,"S",IBDFT))

                       if 'IBDFT!($PIECE(IBDFT,".",1)>IBDFEND)

                           QUIT 

                       IF $DATA(^DPT(IBDFPAT,"S",IBDFT,0))

                           DO SET

 +3        IF VAUTN=0

               FOR IBDFPAT=0:0

                   SET IBDFPAT=$ORDER(VAUTN(IBDFPAT))

                   if 'IBDFPAT

                       QUIT 

                   FOR IBDFT=IBDFBEG:0

                       SET IBDFT=$ORDER(^DPT(IBDFPAT,"S",IBDFT))

                       if 'IBDFT!($PIECE(IBDFT,".",1)>IBDFEND)

                           QUIT 

                       IF $DATA(^DPT(IBDFPAT,"S",IBDFT,0))

                           DO SET

 +4        DO TRACKING

           QUIT 

GRP        DO GRP1^IBDFFT

 +1        NEW IBDFGRP,IBDFCLIN

 +2        FOR IBDFGRP=0:0

               SET IBDFGRP=$ORDER(VAUTG(IBDFGRP))

               if 'IBDFGRP

                   QUIT 

               FOR IBDFCLIN=0:0

                   SET IBDFCLIN=$ORDER(VAUTG(IBDFGRP,IBDFCLIN))

                   if 'IBDFCLIN

                       QUIT 

                   DO CK(IBDFCLIN)

                   IF QUIT=1

                       DO BLD

 +3        DO TRACKING

           QUIT 

 +4       ;

 +5       ;

SET        SET IBDFCLIN=$PIECE(^DPT(IBDFPAT,"S",IBDFT,0),"^",1)

           DO CK(IBDFCLIN)

           IF QUIT=1

               SET DFN=IBDFPAT

               DO CK1

               QUIT 

 +1        QUIT 

 +2       ;

 +3       ;

CK(XCL)   ;  -- Check clinic, division, form

 +1        if '$DATA(^SC(+XCL,0))

               QUIT 

 +2        SET QUIT=0

 +3        SET IBDFNODE=$GET(^SC(XCL,0))

 +4        if $PIECE(IBDFNODE,"^",3)'="C"

               QUIT 

 +5        IF $GET(VAUTD)=0

               IF $PIECE(IBDFNODE,"^",15)

                   if '$DATA(VAUTD($PIECE(IBDFNODE,"^",15)))

                       QUIT 

 +6        DO CHECK^IBDFFT(XCL)

 +7        if QUIT=0

               QUIT 

 +8        QUIT 

 +9       ;

 +10      ;

BLD       ; -- scan appts

 +1        FOR IBDFT=IBDFBEG:0

               SET IBDFT=$ORDER(^SC(IBDFCLIN,"S",IBDFT))

               if 'IBDFT!($PIECE(IBDFT,".",1)>IBDFEND)

                   QUIT 

               Begin DoDot:1

 +2                FOR IBDFDA=0:0

                       SET IBDFDA=$ORDER(^SC(IBDFCLIN,"S",IBDFT,1,IBDFDA))

                       if 'IBDFDA

                           QUIT 

                       IF $DATA(^SC(IBDFCLIN,"S",IBDFT,1,IBDFDA,0))

                           SET IBDFSA=^(0)

                           SET DFN=+IBDFSA

                           DO CK1

               End DoDot:1

 +3        QUIT 

CK1       ; -- 

 +1        NEW IBDFXPC,IBDFYPC

 +2        SET IBDFXPC=$SELECT($DATA(VAUTC)!($DATA(VAUTG)):$PIECE(IBDFNODE,"^",1),1:$PIECE(^DPT(IBDFPAT,0),"^",1))

 +3        SET IBDFYPC=$SELECT($DATA(VAUTC)!($DATA(VAUTG)):$PIECE(^DPT(DFN,0),"^",1),1:$PIECE(IBDFNODE,"^",1))

 +4        IF $DATA(^IBD(357.96,"APTAP",DFN,IBDFT))

               SET IBDFIFN=0

               FOR 

                   SET IBDFIFN=$ORDER(^IBD(357.96,"APTAP",DFN,IBDFT,IBDFIFN))

                   if 'IBDFIFN

                       QUIT 

                   IF $DATA(^IBD(357.96,IBDFIFN,0))

                       Begin DoDot:1

 +5                        IF $DATA(VAUTG)

                               SET ^TMP("FTRK",$JOB,$SELECT($DATA(^DG(40.8,+$PIECE(IBDFNODE,"^",15),0)):$PIECE(^DG(40.8,$PIECE(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),$PIECE(^IBD(357.99,IBDFGRP,0),"^",1),IBDFXPC,IBDFT,IBDFYPC,DFN,+IBDFIFN)=IBDFCLIN_

"^"_^IBD(357.96,IBDFIFN,0)

 +6                        IF '$DATA(VAUTG)

                               SET ^TMP("FTRK",$JOB,$SELECT($DATA(^DG(40.8,+$PIECE(IBDFNODE,"^",15),0)):$PIECE(^DG(40.8,$PIECE(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBDFXPC,IBDFT,IBDFYPC,DFN,+IBDFIFN)=IBDFCLIN_"^"_^IBD(357.96,IBDFIFN,0)

 +7                        QUIT 

                       End DoDot:1

 +8       IF '$TEST

               Begin DoDot:1

 +9                IF $DATA(VAUTG)

                       SET ^TMP("FTRK",$JOB,$SELECT($DATA(^DG(40.8,+$PIECE(IBDFNODE,"^",15),0)):$PIECE(^DG(40.8,$PIECE(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),$PIECE(^IBD(357.99,IBDFGRP,0),"^",1),IBDFXPC,IBDFT,IBDFYPC,DFN,0)=IBDFCLIN_"^^"_DFN_"^"_IB

DFT

 +10               IF '$DATA(VAUTG)

                       SET ^TMP("FTRK",$JOB,$SELECT($DATA(^DG(40.8,+$PIECE(IBDFNODE,"^",15),0)):$PIECE(^DG(40.8,$PIECE(IBDFNODE,"^",15),0),"^",1),1:"NOT SPECIFIED"),IBDFXPC,IBDFT,IBDFYPC,DFN,0)=IBDFCLIN_"^^"_DFN_"^"_IBDFT

               End DoDot:1

 +11       QUIT 

 +12      ;

SETARR    ;  -- Set up Listman array

 +1        SET DFN=$PIECE(IBDFTMP,"^",3)

 +2        IF '$DATA(^TMP("CNT",$JOB,$SELECT(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL))

               Begin DoDot:1

 +3                SET ^TMP("CNT",$JOB,$SELECT(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFCL)="0^0^0^0^0^0^0"

 +4                IF $DATA(VAUTG)

                       IF '$DATA(^TMP("COUNT",$JOB,$SELECT(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL))

                           Begin DoDot:2

 +5                            SET ^TMP("COUNT",$JOB,$SELECT(IBDFDV]"":IBDFDV,1:"NOT SPECIFIED"),IBDFGR,IBDFCL)=1

                           End DoDot:2

               End DoDot:1

 +6        IF $DATA(VAUTG)

               KILL IBDFLAG

               IF $DATA(^TMP("COUNT",$JOB,IBDFCL,IBDFT,IBDFIFN))

                   IF IBDFGR=^TMP("COUNT",$JOB,IBDFCL,IBDFT,IBDFIFN)

                       DO COUNT

 +7        IF $DATA(VAUTG)

               IF '$DATA(^TMP("COUNT",$JOB,IBDFCL,IBDFT,IBDFIFN))

                   DO COUNT

 +8        IF '$DATA(VAUTG)

               SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",1)=$PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",1)+1

 +9        SET IBDCNT1=IBDCNT1+1

 +10       SET IBDCNT=IBDCNT+1

           SET VALMCNT=VALMCNT+1

 +11       SET X=""

 +12       SET IBDFVAL=$JUSTIFY(IBDCNT1_")",5)

 +13       SET X=$$SETSTR^VALM1(IBDFVAL,X,1,5)

 +14       SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",2)

 +15       SET X=$$SETSTR^VALM1(IBDFVAL,X,7,8)

 +16       SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",4)

           IF IBDFVAL

               SET DNKA=$$DNKA(DFN,IBDFVAL)

               SET IBDFVAL=$PIECE($$FMTE^XLFDT(IBDFVAL,2),":",1,2)

 +17       SET X=$$SETSTR^VALM1(IBDFVAL,X,17,14)

 +18       IF $DATA(VAUTC)!($DATA(VAUTG))

               SET (IBDFVAL,IBDFN)=$PIECE($GET(IBDFTMP),"^",3)

               IF IBDFVAL]""

                   SET IBDFVAL=$PIECE(^DPT(IBDFVAL,0),"^",1)

 +19       IF $DATA(VAUTN)

               SET (IBDFVAL,IBDFN)=$PIECE($GET(IBDFTMP),"^",1)

               IF IBDFVAL]""

                   SET IBDFVAL=$PIECE(^SC(IBDFVAL,0),"^",1)

 +20       SET X=$$SETSTR^VALM1(IBDFVAL,X,34,15)

 +21       SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",6)

 +22       IF IBDFVAL]""

               SET IBDFVAL=$EXTRACT(IBDFVAL,4,5)_"/"_$EXTRACT(IBDFVAL,6,7)_"/"_$EXTRACT(IBDFVAL,2,3)

               IF '$DATA(VAUTG)!($DATA(VAUTG)&($DATA(IBDFLAG)))

                   SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",2)=+($PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",2))+1

 +23       SET X=$$SETSTR^VALM1(IBDFVAL,X,50,8)

 +24       SET VAL=$PIECE($GET(IBDFTMP),"^",12)

 +25       SET IBDFVAL=$PIECE($GET(IBDFTMP),"^",7)

 +26       IF IBDFVAL]""

               SET IBDFVAL=$EXTRACT(IBDFVAL,4,5)_"/"_$EXTRACT(IBDFVAL,6,7)_"/"_$EXTRACT(IBDFVAL,2,3)

               IF '$DATA(VAUTG)!($DATA(VAUTG)&($DATA(IBDFLAG)))

                   IF VAL=2

                       SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",3)=+($PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",3))+1

 +27       SET X=$$SETSTR^VALM1(IBDFVAL,X,61,8)

 +28       NEW IBDFXX

 +29       SET IBDFXX=$SELECT(VAL=3:3,VAL=6:5,1:"")

 +30       IF IBDFXX]""

               IF '$DATA(VAUTG)!($DATA(VAUTG)&($DATA(IBDFLAG)))

                   SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",IBDFXX)=$PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",IBDFXX)+1

                   SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",6)=$PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",6)+1