IBDFFT ;ALB/MAF - FORMS TRACKING ; JUL 6 1995@800
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
;
OUT S IBDF2=0
S DIR("B")="CLINIC",DIR(0)="SBM^C:CLINIC;P:PATIENT;G:GROUP (CLINIC)",DIR("A")="Sort by [C]linic, [P]atient, [G]roup (Clinic)" D ^DIR
K DIR I $D(DIRUT)&('$D(IBDF1))!(Y<0) G EXIT
I $D(DIRUT)&$D(IBDF1) G QUIT
S X=$S("Pp"[X:2,"Gg"[X:3,1:1)
S IBDFSR=$E(X)
I $D(^DG(43,1,"GL")) S IBDFMUL=$P(^DG(43,1,"GL"),"^",2)
S IBDFL=$S(IBDFSR=1:"CLN",IBDFSR=2:"PAT",IBDFSR=3:"GRP",1:"QUIT")
I $D(IBDFMUL),IBDFMUL D DIVISION^VAUTOMA G:Y=-1 QUIT
I 'IBDFMUL S IBDFDV=$O(^DG(40.8,0)) S VAUTD=0,VAUTD(+$O(^DG(40.8,0)))=$P($G(^DG(40.8,+$O(^DG(40.8,0)),0)),"^")
D @(IBDFL) G:Y=-1 QUIT ;I IBDFL="GRP" D GRP1
D DAT G:Y=-1 QUIT
OKQ N IBQUEUE S %=1 W !!,"Do you want to queue this to a printer?" D YN^DICN I '% D YN G OKQ
I %=1 S IBQUEUE=1
I $D(IBQUEUE) G QUEUE
D WAIT^DICD
S IBDFDAT=$$HTE^XLFDT($H)
I '$D(IBDF1) D EN^VALM("IBDF FT REPORT")
I $D(IBDF1) D KILL,START^IBDFFT1 S VALMBCK="R",VALMBG=1
Q
;
;
SAVE ; -- save variables for queue
S ZTSAVE("^TMP(""FTRK"",$J,")="",ZTSAVE("^TMP(""COUNT"",$J,")="",ZTSAVE("^TMP(""FRM"",$J,")="",ZTSAVE("^TMP(""CNT"",$J,")="",ZTSAVE("^TMP(""STATS"",$J,")="",ZTSAVE("VA*")="",ZTSAVE("VAUTG(")="",ZTSAVE("VAUTN(")="",ZTSAVE("VAUTC(")=""
Q
QUEUE W !!,$C(7),"** Report requires 132 columns and a page length of 80 lines. **",!
N ZTSK,ZTDTH,ZTRTN,ZTDESC,ZTSAVE,ZTION,X,Y
K %IS,%ZIS,IOP S IOP="Q",%ZIS="QM0",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="^IBDFFT3",ZTDESC="Forms Tracking Report",ZTSAVE("^TMP(""FTRK"",$J,")="",ZTSAVE("IB*")="" D SAVE D ^%ZTLOAD K IO("Q") W !,$S($D(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled") D HOME^%ZIS G EXIT
I '$D(ZTQUEUED) D ^%ZISC
CLEAR ; -- Clean up variables if task is not queued
D ^IBDFFT3
G EXIT ;K ^TMP("IBDF",$J),^TMP("IB",$J)
Q
HDR ; -- header code
S VALMHDR(1)="Encounter forms - printed; scanned (to PCE, w/ERrors); pending pages;"
S VALMHDR(2)="data entry (to PCE,w/ERrors); error detected,not transmitted; not printed."
Q
;
CLN S VAUTNI=2,DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)",VAUTSTR="clinic",VAUTVB="VAUTC" D FIRST^VAUTOMA S:Y=-1 IBDF2=1 Q:IBDF2
Q
;
;
PAT S VAUTNI=2 D PATIENT^VAUTOMA S:Y=-1 IBDF2=1 Q:IBDF2
Q
;
;
GRP S VAUTNI=2,DIC="^IBD(357.99,",VAUTSTR="clinic group",VAUTVB="VAUTG" D FIRST^VAUTOMA S:Y=-1 IBDF2=1 Q:IBDF2
Q
GRP1 N IBGROUP
I VAUTG=1 D
.S IBGROUP=0 F S IBGROUP=$O(^IBD(357.99,IBGROUP)) Q:'IBGROUP I $D(^IBD(357.99,IBGROUP,0)) S VAUTG(IBGROUP)=$P(^IBD(357.99,IBGROUP,0),"^",1)
.Q
S IBGROUP=0 F S IBGROUP=$O(VAUTG(IBGROUP)) Q:'IBGROUP D
.N IBCLI,IBDIV,IBCLNUM,IBDIVNUM
.S IBCLI=0 F S IBCLI=$O(^IBD(357.99,IBGROUP,10,IBCLI)) Q:'IBCLI I $D(^IBD(357.99,IBGROUP,10,IBCLI,0)) S IBCLNUM=+^IBD(357.99,IBGROUP,10,IBCLI,0) I $D(^SC(+IBCLNUM,0)) D
..S VAUTG(IBGROUP,IBCLNUM)=$P(^SC(+IBCLNUM,0),"^",1)
..Q
.S IBDIV=0 F S IBDIV=$O(^IBD(357.99,IBGROUP,11,IBDIV)) Q:'IBDIV I $D(^IBD(357.99,IBGROUP,11,IBDIV,0)) S IBDIVNUM=+^IBD(357.99,IBGROUP,11,IBDIV,0) I $D(^DG(40.8,IBDIVNUM,0)) D
..S IBCLNUM=0 F S IBCLNUM=$O(^SC(IBCLNUM)) Q:'IBCLNUM I $D(^SC(IBCLNUM,0)) I +$P(^SC(IBCLNUM,0),"^",15)=IBDIVNUM S VAUTG(IBGROUP,IBCLNUM)=$P(^SC(IBCLNUM,0),"^",1)
..Q
Q
;
;
CHECK(CLIN) ; -- Check to see if clinic has a form and its one that is not for
; future use only.
N IBDFNODE,IBDFCL,X
S QUIT=0
I $O(^SD(409.95,"B",+CLIN,0)) D
.S IBDFCL=$O(^SD(409.95,"B",+CLIN,0))
.S IBDFNODE=^SD(409.95,IBDFCL,0)
.S QUIT=0 F X=2:1:9 S:$P(IBDFNODE,"^",X)&("^1^2^3^4^5^6^8^9^"[X) QUIT=1 Q:QUIT
Q
;
;
EXIT ; -- Code executed at action exit
K IBDFL,IBDFL1,IBDFBG,IBDFBG1,IBDFBEG,IBDFBEG1,IBDFEND,IBDFEND1,VAUTD,VAUTN,VAUTC,IBDFC1,IBDFN1,IBDFDV1,VAUTD1,VAUTC1,VAUTN1,IBDFN,DNKA,VAUTG,IBDFGRO
EXIT1 ;
K DFN,IBDFCLI,IBDFDA,IBDFDAT,IBDFIFN,IBDFMUL,IBDFSA,IBDFSR,IBDFT,IBDVAL,IBDFVAL,IBDVAL1,QUIT,IBDF2,IBDNKA,IBDX
K ^TMP("CNT",$J),^TMP("FRM",$J),^TMP("FTRK",$J),^TMP("STATS",$J),^TMP("FRMIDX",$J),^TMP("STAIDX",$J),^TMP("COUNT",$J),IBDFDIV,IBDFCLIN,IBDFNODE,IBDFGROP
D ^%ZISC
Q
;
;
DAT ; -- DATE RANGE
BEG W ! S %DT="AEX",%DT("A")="BEGINNING DATE: " D ^%DT S IBDFBG=Y,IBDFBEG=Y-.0001 S:X="^"!(X="") Y=-1 Q:Y=-1
END W ! S %DT("A")="ENDING DATE: " D ^%DT S:X="^"!(X="") Y=-1 Q:Y=-1 I Y<1 D HELP^%DTC G END
S IBDFEND=Y_.9999
I IBDFEND\1<IBDFBG W !!?5,"The ending date cannot be before the beginning date" G END
Q
;
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
CHGLST ; -- Code to change list display
D FULL^VALM1
S IBDFL1=IBDFL,IBDFBG1=IBDFBG,IBDFBEG1=IBDFBEG,IBDFEND1=IBDFEND
S IBDFDV1=VAUTD S:$D(VAUTC) IBDFC1=VAUTC S:$D(VAUTN) IBDFN1=VAUTN
I $D(VAUTG) S IBDFG1=VAUTG
I VAUTD=0 F X=0:0 S X=$O(VAUTD(X)) Q:X']"" S VAUTD1(X)=VAUTD(X)
I $D(VAUTC),VAUTC=0 F X=0:0 S X=$O(VAUTC(X)) Q:X']"" S VAUTC1(X)=VAUTC(X)
I $D(VAUTN),VAUTN=0 F X=0:0 S X=$O(VAUTN(X)) Q:X']"" S VAUTN1(X)=VAUTN(X)
I $D(VAUTG) D
.N IBX
.S IBX=0
.F X=0:0 S X=$O(VAUTG(X)) Q:X']"" F Y=0:0 S Y=$O(VAUTG(X,Y)) Q:Y']"" S VAUTG1(X,Y)=VAUTG(X,Y)
D EXIT1,OUT
Q
KILL ; -- Kill extra array variables
N IBDFXX
S IBDFXX=$S(IBDFL="CLN":"VAUTC",IBDFL="GRP":"VAUTG",1:"VAUTN")
I IBDFXX="VAUTN" K VAUTC,VAUTG
I IBDFXX="VAUTC" K VAUTN,VAUTG
I IBDFXX="VAUTG" K VAUTN,VAUTC
Q
QUIT ; -- Kill variables and reset to last display if no change has taken place
I $D(IBDF1) S IBDFL=IBDFL1,IBDFBG=IBDFBG1,IBDFBEG=IBDFBEG1,IBDFEND=IBDFEND1,VAUTD=IBDFDV1 S:IBDFL="CLN" VAUTC=IBDFC1 S:IBDFL="PAT" VAUTN=IBDFN1 S:IBDFL="GRP" VAUTG=IBDFG1 D
.I VAUTD=0 F X=0:0 S X=$O(VAUTD1(X)) Q:X']"" S VAUTD(X)=VAUTD1(X)
.I $D(VAUTC),VAUTC=0 F X=0:0 S X=$O(VAUTC1(X)) Q:X']"" S VAUTC(X)=VAUTC1(X)
.I $D(VAUTN),VAUTN=0 F X=0:0 S X=$O(VAUTN1(X)) Q:X']"" S VAUTN(X)=VAUTN1(X)
.I $D(VAUTG) D
..F X=0:0 S X=$O(VAUTG1(X)) Q:X']"" F Y=0:0 S Y=$O(VAUTG1(X,Y)) Q:Y']"" S VAUTG(X,Y)=VAUTG1(X,Y)
I '$D(IBDF1) G EXIT
D KILL,START^IBDFFT1 S VALMBCK="R",VALMBG=1
Q
;
SCHSTAT(DFN,APPT) ; -- return text of scheduling status
;
N X
S X=$$REQ^IBDFDE0(DFN,APPT,+$G(^DPT(DFN,"S",APPT,0)),$$FNDSDOE^IBDFDE(DFN,APPT))
S X=$S(X=1:"CO Required",X=-1:"CO Complete",1:"CO Not Req.")
Q X
YN W !?10,"Choose:",!?25,"Y for YES",!?25,"N for NO",! Q
IBDFFT ;ALB/MAF - FORMS TRACKING ; JUL 6 1995@800
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
+3 ;
OUT SET IBDF2=0
+1 SET DIR("B")="CLINIC"
SET DIR(0)="SBM^C:CLINIC;P:PATIENT;G:GROUP (CLINIC)"
SET DIR("A")="Sort by [C]linic, [P]atient, [G]roup (Clinic)"
DO ^DIR
+2 KILL DIR
IF $DATA(DIRUT)&('$DATA(IBDF1))!(Y<0)
GOTO EXIT
+3 IF $DATA(DIRUT)&$DATA(IBDF1)
GOTO QUIT
+4 SET X=$SELECT("Pp"[X:2,"Gg"[X:3,1:1)
+5 SET IBDFSR=$EXTRACT(X)
+6 IF $DATA(^DG(43,1,"GL"))
SET IBDFMUL=$PIECE(^DG(43,1,"GL"),"^",2)
+7 SET IBDFL=$SELECT(IBDFSR=1:"CLN",IBDFSR=2:"PAT",IBDFSR=3:"GRP",1:"QUIT")
+8 IF $DATA(IBDFMUL)
IF IBDFMUL
DO DIVISION^VAUTOMA
IF Y=-1
GOTO QUIT
+9 IF 'IBDFMUL
SET IBDFDV=$ORDER(^DG(40.8,0))
SET VAUTD=0
SET VAUTD(+$ORDER(^DG(40.8,0)))=$PIECE($GET(^DG(40.8,+$ORDER(^DG(40.8,0)),0)),"^")
+10 ;I IBDFL="GRP" D GRP1
DO @(IBDFL)
IF Y=-1
GOTO QUIT
+11 DO DAT
IF Y=-1
GOTO QUIT
OKQ NEW IBQUEUE
SET %=1
WRITE !!,"Do you want to queue this to a printer?"
DO YN^DICN
IF '%
DO YN
GOTO OKQ
+1 IF %=1
SET IBQUEUE=1
+2 IF $DATA(IBQUEUE)
GOTO QUEUE
+3 DO WAIT^DICD
+4 SET IBDFDAT=$$HTE^XLFDT($HOROLOG)
+5 IF '$DATA(IBDF1)
DO EN^VALM("IBDF FT REPORT")
+6 IF $DATA(IBDF1)
DO KILL
DO START^IBDFFT1
SET VALMBCK="R"
SET VALMBG=1
+7 QUIT
+8 ;
+9 ;
SAVE ; -- save variables for queue
+1 SET ZTSAVE("^TMP(""FTRK"",$J,")=""
SET ZTSAVE("^TMP(""COUNT"",$J,")=""
SET ZTSAVE("^TMP(""FRM"",$J,")=""
SET ZTSAVE("^TMP(""CNT"",$J,")=""
SET ZTSAVE("^TMP(""STATS"",$J,")=""
SET ZTSAVE("VA*")=""
SET ZTSAVE("VAUTG(")=""
SET ZTSAVE("VAUTN(")=""
SET ZTSAVE("VAUTC(")=""
+2 QUIT
QUEUE WRITE !!,$CHAR(7),"** Report requires 132 columns and a page length of 80 lines. **",!
+1 NEW ZTSK,ZTDTH,ZTRTN,ZTDESC,ZTSAVE,ZTION,X,Y
+2 KILL %IS,%ZIS,IOP
SET IOP="Q"
SET %ZIS="QM0"
SET %ZIS("A")="OUTPUT DEVICE: "
DO ^%ZIS
IF POP
GOTO EXIT
+3 IF $DATA(IO("Q"))
SET ZTRTN="^IBDFFT3"
SET ZTDESC="Forms Tracking Report"
SET ZTSAVE("^TMP(""FTRK"",$J,")=""
SET ZTSAVE("IB*")=""
DO SAVE
DO ^%ZTLOAD
KILL IO("Q")
WRITE !,$SELECT($DATA(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled")
DO HOME^%ZIS
GOTO EXIT
+4 IF '$DATA(ZTQUEUED)
DO ^%ZISC
CLEAR ; -- Clean up variables if task is not queued
+1 DO ^IBDFFT3
+2 ;K ^TMP("IBDF",$J),^TMP("IB",$J)
GOTO EXIT
+3 QUIT
HDR ; -- header code
+1 SET VALMHDR(1)="Encounter forms - printed; scanned (to PCE, w/ERrors); pending pages;"
+2 SET VALMHDR(2)="data entry (to PCE,w/ERrors); error detected,not transmitted; not printed."
+3 QUIT
+4 ;
CLN SET VAUTNI=2
SET DIC="^SC("
SET DIC("S")="I $P(^(0),U,3)=""C""&$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)"
SET VAUTSTR="clinic"
SET VAUTVB="VAUTC"
DO FIRST^VAUTOMA
IF Y=-1
SET IBDF2=1
IF IBDF2
QUIT
+1 QUIT
+2 ;
+3 ;
PAT SET VAUTNI=2
DO PATIENT^VAUTOMA
IF Y=-1
SET IBDF2=1
IF IBDF2
QUIT
+1 QUIT
+2 ;
+3 ;
GRP SET VAUTNI=2
SET DIC="^IBD(357.99,"
SET VAUTSTR="clinic group"
SET VAUTVB="VAUTG"
DO FIRST^VAUTOMA
IF Y=-1
SET IBDF2=1
IF IBDF2
QUIT
+1 QUIT
GRP1 NEW IBGROUP
+1 IF VAUTG=1
Begin DoDot:1
+2 SET IBGROUP=0
FOR
SET IBGROUP=$ORDER(^IBD(357.99,IBGROUP))
IF 'IBGROUP
QUIT
IF $DATA(^IBD(357.99,IBGROUP,0))
SET VAUTG(IBGROUP)=$PIECE(^IBD(357.99,IBGROUP,0),"^",1)
+3 QUIT
End DoDot:1
+4 SET IBGROUP=0
FOR
SET IBGROUP=$ORDER(VAUTG(IBGROUP))
IF 'IBGROUP
QUIT
Begin DoDot:1
+5 NEW IBCLI,IBDIV,IBCLNUM,IBDIVNUM
+6 SET IBCLI=0
FOR
SET IBCLI=$ORDER(^IBD(357.99,IBGROUP,10,IBCLI))
IF 'IBCLI
QUIT
IF $DATA(^IBD(357.99,IBGROUP,10,IBCLI,0))
SET IBCLNUM=+^IBD(357.99,IBGROUP,10,IBCLI,0)
IF $DATA(^SC(+IBCLNUM,0))
Begin DoDot:2
+7 SET VAUTG(IBGROUP,IBCLNUM)=$PIECE(^SC(+IBCLNUM,0),"^",1)
+8 QUIT
End DoDot:2
+9 SET IBDIV=0
FOR
SET IBDIV=$ORDER(^IBD(357.99,IBGROUP,11,IBDIV))
IF 'IBDIV
QUIT
IF $DATA(^IBD(357.99,IBGROUP,11,IBDIV,0))
SET IBDIVNUM=+^IBD(357.99,IBGROUP,11,IBDIV,0)
IF $DATA(^DG(40.8,IBDIVNUM,0))
Begin DoDot:2
+10 SET IBCLNUM=0
FOR
SET IBCLNUM=$ORDER(^SC(IBCLNUM))
IF 'IBCLNUM
QUIT
IF $DATA(^SC(IBCLNUM,0))
IF +$PIECE(^SC(IBCLNUM,0),"^",15)=IBDIVNUM
SET VAUTG(IBGROUP,IBCLNUM)=$PIECE(^SC(IBCLNUM,0),"^",1)
+11 QUIT
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
+14 ;
CHECK(CLIN) ; -- Check to see if clinic has a form and its one that is not for
+1 ; future use only.
+2 NEW IBDFNODE,IBDFCL,X
+3 SET QUIT=0
+4 IF $ORDER(^SD(409.95,"B",+CLIN,0))
Begin DoDot:1
+5 SET IBDFCL=$ORDER(^SD(409.95,"B",+CLIN,0))
+6 SET IBDFNODE=^SD(409.95,IBDFCL,0)
+7 SET QUIT=0
FOR X=2:1:9
IF $PIECE(IBDFNODE,"^",X)&("^1^2^3^4^5^6^8^9^"[X)
SET QUIT=1
IF QUIT
QUIT
End DoDot:1
+8 QUIT
+9 ;
+10 ;
EXIT ; -- Code executed at action exit
+1 KILL IBDFL,IBDFL1,IBDFBG,IBDFBG1,IBDFBEG,IBDFBEG1,IBDFEND,IBDFEND1,VAUTD,VAUTN,VAUTC,IBDFC1,IBDFN1,IBDFDV1,VAUTD1,VAUTC1,VAUTN1,IBDFN,DNKA,VAUTG,IBDFGRO
EXIT1 ;
+1 KILL DFN,IBDFCLI,IBDFDA,IBDFDAT,IBDFIFN,IBDFMUL,IBDFSA,IBDFSR,IBDFT,IBDVAL,IBDFVAL,IBDVAL1,QUIT,IBDF2,IBDNKA,IBDX
+2 KILL ^TMP("CNT",$JOB),^TMP("FRM",$JOB),^TMP("FTRK",$JOB),^TMP("STATS",$JOB),^TMP("FRMIDX",$JOB),^TMP("STAIDX",$JOB),^TMP("COUNT",$JOB),IBDFDIV,IBDFCLIN,IBDFNODE,IBDFGROP
+3 DO ^%ZISC
+4 QUIT
+5 ;
+6 ;
DAT ; -- DATE RANGE
BEG WRITE !
SET %DT="AEX"
SET %DT("A")="BEGINNING DATE: "
DO ^%DT
SET IBDFBG=Y
SET IBDFBEG=Y-.0001
IF X="^"!(X="")
SET Y=-1
IF Y=-1
QUIT
END WRITE !
SET %DT("A")="ENDING DATE: "
DO ^%DT
IF X="^"!(X="")
SET Y=-1
IF Y=-1
QUIT
IF Y<1
DO HELP^%DTC
GOTO END
+1 SET IBDFEND=Y_.9999
+2 IF IBDFEND\1<IBDFBG
WRITE !!?5,"The ending date cannot be before the beginning date"
GOTO END
+3 QUIT
+4 ;
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
CHGLST ; -- Code to change list display
+1 DO FULL^VALM1
+2 SET IBDFL1=IBDFL
SET IBDFBG1=IBDFBG
SET IBDFBEG1=IBDFBEG
SET IBDFEND1=IBDFEND
+3 SET IBDFDV1=VAUTD
IF $DATA(VAUTC)
SET IBDFC1=VAUTC
IF $DATA(VAUTN)
SET IBDFN1=VAUTN
+4 IF $DATA(VAUTG)
SET IBDFG1=VAUTG
+5 IF VAUTD=0
FOR X=0:0
SET X=$ORDER(VAUTD(X))
IF X']""
QUIT
SET VAUTD1(X)=VAUTD(X)
+6 IF $DATA(VAUTC)
IF VAUTC=0
FOR X=0:0
SET X=$ORDER(VAUTC(X))
IF X']""
QUIT
SET VAUTC1(X)=VAUTC(X)
+7 IF $DATA(VAUTN)
IF VAUTN=0
FOR X=0:0
SET X=$ORDER(VAUTN(X))
IF X']""
QUIT
SET VAUTN1(X)=VAUTN(X)
+8 IF $DATA(VAUTG)
Begin DoDot:1
+9 NEW IBX
+10 SET IBX=0
+11 FOR X=0:0
SET X=$ORDER(VAUTG(X))
IF X']""
QUIT
FOR Y=0:0
SET Y=$ORDER(VAUTG(X,Y))
IF Y']""
QUIT
SET VAUTG1(X,Y)=VAUTG(X,Y)
End DoDot:1
+12 DO EXIT1
DO OUT
+13 QUIT
KILL ; -- Kill extra array variables
+1 NEW IBDFXX
+2 SET IBDFXX=$SELECT(IBDFL="CLN":"VAUTC",IBDFL="GRP":"VAUTG",1:"VAUTN")
+3 IF IBDFXX="VAUTN"
KILL VAUTC,VAUTG
+4 IF IBDFXX="VAUTC"
KILL VAUTN,VAUTG
+5 IF IBDFXX="VAUTG"
KILL VAUTN,VAUTC
+6 QUIT
QUIT ; -- Kill variables and reset to last display if no change has taken place
+1 IF $DATA(IBDF1)
SET IBDFL=IBDFL1
SET IBDFBG=IBDFBG1
SET IBDFBEG=IBDFBEG1
SET IBDFEND=IBDFEND1
SET VAUTD=IBDFDV1
IF IBDFL="CLN"
SET VAUTC=IBDFC1
IF IBDFL="PAT"
SET VAUTN=IBDFN1
IF IBDFL="GRP"
SET VAUTG=IBDFG1
Begin DoDot:1
+2 IF VAUTD=0
FOR X=0:0
SET X=$ORDER(VAUTD1(X))
IF X']""
QUIT
SET VAUTD(X)=VAUTD1(X)
+3 IF $DATA(VAUTC)
IF VAUTC=0
FOR X=0:0
SET X=$ORDER(VAUTC1(X))
IF X']""
QUIT
SET VAUTC(X)=VAUTC1(X)
+4 IF $DATA(VAUTN)
IF VAUTN=0
FOR X=0:0
SET X=$ORDER(VAUTN1(X))
IF X']""
QUIT
SET VAUTN(X)=VAUTN1(X)
+5 IF $DATA(VAUTG)
Begin DoDot:2
+6 FOR X=0:0
SET X=$ORDER(VAUTG1(X))
IF X']""
QUIT
FOR Y=0:0
SET Y=$ORDER(VAUTG1(X,Y))
IF Y']""
QUIT
SET VAUTG(X,Y)=VAUTG1(X,Y)
End DoDot:2
End DoDot:1
+7 IF '$DATA(IBDF1)
GOTO EXIT
+8 DO KILL
DO START^IBDFFT1
SET VALMBCK="R"
SET VALMBG=1
+9 QUIT
+10 ;
SCHSTAT(DFN,APPT) ; -- return text of scheduling status
+1 ;
+2 NEW X
+3 SET X=$$REQ^IBDFDE0(DFN,APPT,+$GET(^DPT(DFN,"S",APPT,0)),$$FNDSDOE^IBDFDE(DFN,APPT))
+4 SET X=$SELECT(X=1:"CO Required",X=-1:"CO Complete",1:"CO Not Req.")
+5 QUIT X
YN WRITE !?10,"Choose:",!?25,"Y for YES",!?25,"N for NO",!
QUIT
