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 ---[H[J[2J[HIBDFFT1 9846 printed Oct 16, 2024@18:53:19 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
+31 SET VAL=$SELECT(DNKA:$PIECE(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")
+32 IF DNKA
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",7)=+($PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",7))+1
+33 SET X=$$SETSTR^VALM1(VAL,X,72,8)
+34 SET IBDFVAL=$SELECT(DNKA:"",1:$$SCHSTAT^IBDFFT($PIECE(IBDFTMP,"^",3),$PIECE(IBDFTMP,"^",4)))
+35 SET X=$$SETSTR^VALM1(IBDFVAL,X,82,12)
+36 SET IBDFVAL=$SELECT($PIECE(IBDFTMP,"^",14):" Yes",1:" No")
+37 SET X=$$SETSTR^VALM1(IBDFVAL,X,96,6)
+38 ;
+39 ;
TMP ; -- Set up TMP Array
+1 SET ^TMP("FRM",$JOB,IBDCNT,0)=$$LOWER^VALM1(X)
SET ^TMP("FRM",$JOB,"IDX",VALMCNT,IBDCNT1)=""
+2 SET ^TMP("FRMIDX",$JOB,IBDCNT1)=VALMCNT_"^"_$PIECE(IBDFTMP,"^",2)_"^"_$PIECE(IBDFTMP,"^",3)_"^"_$PIECE(IBDFTMP,"^",4)_"^"_$PIECE(IBDFTMP,"^",6)_"^"_$PIECE(IBDFTMP,"^",7)_"^"_$PIECE(IBDFTMP,"^",12)
+3 DO NOW^%DTC
SET IBDFTIME=%
SET X1=$SELECT($PIECE(IBDFTMP,"^",7):$PIECE(IBDFTMP,"^",7),1:IBDFTIME)
SET X2=$PIECE(IBDFTMP,"^",4)
DO ^%DTC
SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",4)=+($PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",4))+X
+4 QUIT
COUNT ;
+1 SET ^TMP("COUNT",$JOB,IBDFCL,IBDFT,IBDFIFN)=IBDFGR
SET IBDFLAG=1
+2 SET $PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",1)=$PIECE(^TMP("CNT",$JOB,IBDFDV,IBDFCL),"^",1)+1
+3 QUIT
TRACKING ; -- loops thru forms tracking file 357.96
+1 ; X-reference ^IBD(357.96,"ADATNA", Appt date/time, 1 or 0, IFN).
+2 ; 1 = forms tracking file entry but no scheduled appt associated
+3 ; 0 = forms tracking file entry with associated scheduled appt.
+4 NEW IBDFCLIN,IBAPPTDT,IBDFPAT,IBDFTRK,IBDFX,IBDFT
+5 SET IBDFX=""
+6 FOR IBDFT=IBDFBEG:0
SET IBDFT=$ORDER(^IBD(357.96,"ADATNA",IBDFT))
if 'IBDFT!(IBDFT>IBDFEND)
QUIT
SET IBDFTRK=0
FOR
SET IBDFTRK=$ORDER(^IBD(357.96,"ADATNA",IBDFT,1,IBDFTRK))
if 'IBDFTRK
QUIT
Begin DoDot:1
+7 if '$GET(^IBD(357.96,IBDFTRK,0))
QUIT
+8 SET IBDFCLIN=$PIECE(^IBD(357.96,IBDFTRK,0),"^",10)
+9 IF IBDFCLIN']""
QUIT
+10 SET IBDFPAT=$PIECE(^IBD(357.96,IBDFTRK,0),"^",2)
+11 DO CK(IBDFCLIN)
IF QUIT=1
Begin DoDot:2
+12 IF $DATA(VAUTC)
IF VAUTC=0
IF '$DATA(VAUTC(IBDFCLIN))
QUIT
+13 IF $DATA(VAUTN)
IF VAUTN=0
IF '$DATA(VAUTN(IBDFPAT))
QUIT
+14 NEW IBDFXPC,IBDFYPC
+15 SET IBDFXPC=$SELECT($DATA(VAUTC):$PIECE(IBDFNODE,"^",1),$DATA(VAUTG):$PIECE(IBDFNODE,"^",1),1:$PIECE(^DPT(IBDFPAT,0),"^",1))
+16 SET IBDFYPC=$SELECT($DATA(VAUTC)!($DATA(VAUTG)):$PIECE(^DPT(IBDFPAT,0),"^",1),1:$PIECE(IBDFNODE,"^",1))
+17 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,IBDFPAT,IBDFTRK)=IBDFCLIN_"^"_^IBD(357.96,IBDFTRK,0)
+18 IF $DATA(VAUTG)
Begin DoDot:3
+19 NEW IBDFGRP,IBDFCLNN,IBDFCLN,IBDFGR
+20 SET (IBDFCLN,IBDFGR)=0
+21 FOR IBDFGR=0:0
SET IBDFGR=$ORDER(VAUTG(IBDFGR))
if IBDFGR']""
QUIT
FOR IBDFCLN=0:0
SET IBDFCLN=$ORDER(VAUTG(IBDFGR,IBDFCLN))
if IBDFCLN']""
QUIT
IF IBDFCLN=IBDFCLIN
Begin DoDot:4
+22 NEW IBX,IBY
+23 SET IBX=$PIECE($GET(^IBD(357.99,IBDFGR,0)),"^")
SET IBY=$PIECE($GET(^SC(IBDFCLN,0)),"^")
+24 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"),IBX,IBY,IBDFT,IBDFYPC,IBDFPAT,IBDFTRK)=IBDFCLIN_"^"_^IBD(3
57.96,IBDFTRK,0)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
DNKA(DFN,APPT) ;
+1 ; -- return did not keep appointment
+2 NEW STATUS,DNKA
+3 SET DNKA=0
+4 SET STATUS=$PIECE($GET(^DPT(+$GET(DFN),"S",+$GET(APPT),0)),"^",2)
+5 IF STATUS]""
IF "^N^C^NA^CA^PC^PCA^"[STATUS
SET DNKA=1_"^"_$SELECT(STATUS["N":"NO SHOW",1:"CANCELED")
+6 QUIT DNKA
