source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFFT.m@ 1607

IBDFFT ;ALB/MAF - FORMS TRACKING ; JUL 6 1995@800
 ;;3.0;AUTOMATED INFO COLLECTION SYS;**16**;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 G EXIT
 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,%DT,VAL,POP,IBDFG1,DIR,VAUTVB
 K %,DIC,DIRUT,IBDF1,VALMBCK,VALMBG,VALMHDR,VAUTG1,VAUTNI,VAUTSTR,ZTQUEUED,X,X1,X2,D0,DA,DIK,%ZIS,IOP,CLIN,APPT
 K IBDCNT,IBDCNT1,IBDFCL,IBDFDV,IBDFGR,VALMCNT,IBDFPAGE,IFN,VALMY
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