Routine: SDST

SDST ;BSN/GRR - PRINT ENROLLMENTS OLDER THAN X NUMBER OF DAYS ; 14 JUL 83  10:41 AM

 ;;5.3;Scheduling;**32,79,1015**;Aug 13, 1993;Build 21

 S DIV="" D DIV^SDUTL I $T S DIC("A")="ENROLLMENTS > X DAYS FOR WHICH DIVISION: " D ASK^SDDIV K DIC("A") Q:Y<0

RD R !,"MINIMUM DAYS OLD ENROLLMENT DATE MUST BE: ",X:DTIME I X?.E1"?" D HELP G RD

 Q:"^"[X  I X'?1N.N!('X) D HELP G RD

 S J=X D:'$D(DT) DT^SDUTL S X1=DT,X2=J#J-J D C^%DTC S HDT=X,OLD=J

RD1 S DIC="^SC(",DIC(0)="EFQ",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS"")),$S(DIV="""":1,$P(^(0),""^"",15)=DIV:1,1:0)" R !,"Select Clinic: ",X:DTIME G:"^"[X END I X["?" W !,"ENTER A CLINIC NAME OR 'ALL' TO CHECK ALL CLINICS"

 S X=$$UP^XLFSTR(X) I X'="ALL" D ^DIC K DIC G:Y<0 RD1

 K DIC S SDCL=$S(X="ALL":"ALL",1:+Y)

 I $N(^DPT("AEB",0))'>0!($N(^DPT("AEB",0))'<HDT) W !,*7,*7,"NO ACTIVE ENROLLMENTS THAT OLD",*7,*7 Q

 S VAR="OLD^HDT^SDCL^DIV",VAL=OLD_"^"_HDT_"^"_SDCL_"^"_DIV,PGM="START^SDST" D ZIS^DGUTQ G:POP END

 D WAIT^DICD

START U IO K ^UTILITY($J)

 S NDT=0 F I=0:0 S NDT=$N(^DPT("AEB",NDT)) Q:NDT'>0!(NDT'<HDT)  F K=0:0 S K=$N(^DPT("AEB",NDT,K)) Q:K<0  F L=0:0 S L=$N(^DPT("AEB",NDT,K,L)) Q:L<0  F M=0:0 S M=$N(^DPT("AEB",NDT,K,L,M)) Q:M<0  D:$D(^DPT(K,"DE",L,0)) SET

 D PRT G END

SET S SCN=+^DPT(K,"DE",L,0) Q:$S('$D(^SC(SCN,0)):1,SCN'=SDCL&(SDCL'="ALL"):1,SDCL="ALL":$S(DIV="":0,$P(^SC(SCN,0),"^",15)=DIV:0,1:1),1:0)

 S NAME=$P(^DPT(K,0),"^",1),SSN=$P(^(0),"^",9),SC=$P(^SC(SCN,0),"^",1),TYPE=$P(^DPT(K,"DE",L,1,M,0),"^",2),SDEC=$S($D(^DPT(K,.36)):+^(.36),1:"")

 K N S (Q,P)=0 F N=1:1 S P=$N(^DPT(K,"S",P)) Q:P<0  I $P(^(P,0),"^",1)=SCN,$P(^(0),"^",2)'["C",P>DT S Q=Q+1,N(Q)=P

 S ^UTILITY($J,SC,NAME,0)=SSN_"^"_NDT_"^"_TYPE_"^"_SDEC

 I Q>0 F Z=1:1:Q S ^UTILITY($J,SC,NAME,Z)=N(Z)

PRT K N,L,M,NAME,SSN,SDEC

 S K=0 F J=1:1 S K=$N(^UTILITY($J,K)) Q:K<0  D HEAD S L=0 F LL=0:0 S L=$N(^UTILITY($J,K,L)) Q:L<0  D LINE

LINE D:$Y+3>IOSL HEAD S A=^(L,0) W !,L,?22,$P(A,"^",1),?33 S Y=$P($P(A,"^",2),".",1) D DT^SDM0 ;NAKED REFERENCE - ^UTILITY($J,Clinic Name,0)

 W ?47,$S($D(^DIC(8,+$P(A,"^",4),0)):$E($P(^(0),"^",6),1,20),1:"UNKNOWN"),?70,$P(A,"^",3) S Z=0 F ZZ=1:1 S Z=$N(^UTILITY($J,K,L,Z)) Q:Z<0  W:Z=1 !,?16,"** PENDING APPOINTMENTS: " S Y=^(Z) W:Z'=1 ! W ?42," " D DT^SDM0

HEAD W @IOF,! S Y=DT D DT^SDM0 W ?30,"ACTIVE ENROLLMENTS OVER ",OLD," DAYS",!!,?35,K," CLINIC",!

 W !,"PATIENT NAME",?22,"   SSN",?33,"ENROLL. DATE",?47,"ELIG CODE",?68,"OPT/AC",!

HELP W !,"ENTER THE NUMBER OF DAYS PRIOR TO TODAY THAT AN ENROLLMENT DATE MUST BE",!,"TO BE PRINTED ON THIS REPORT. (I.E. '365' TO PRINT ENROLLMENT DATES PRIOR",!,"TO A YEAR AGO TODAY) - MUST BE A POSITIVE WHOLE #",!

END W ! K A,DIC,HDT,I,J,K,L,LL,M,N,NAME,NDT,OLD,P,Q,SC,SCN,SSN,TYPE,X,X1,X2,Y,Z,ZZ,^UTILITY($J) D CLOSE^DGUTQ Q

SDST      ;BSN/GRR - PRINT ENROLLMENTS OLDER THAN X NUMBER OF DAYS ; 14 JUL 83  10:41 AM

 +1       ;;5.3;Scheduling;**32,79,1015**;Aug 13, 1993;Build 21

 +2        SET DIV=""

           DO DIV^SDUTL

           IF $TEST

               SET DIC("A")="ENROLLMENTS > X DAYS FOR WHICH DIVISION: "

               DO ASK^SDDIV

               KILL DIC("A")

               IF Y<0

                   QUIT

RD         READ !,"MINIMUM DAYS OLD ENROLLMENT DATE MUST BE: ",X:DTIME

           IF X?.E1"?"

               DO HELP

               GOTO RD

 +1        IF "^"[X

               QUIT

           IF X'?1N.N!('X)

               DO HELP

               GOTO RD

 +2        SET J=X

           IF '$DATA(DT)

               DO DT^SDUTL

           SET X1=DT

           SET X2=J#J-J

           DO C^%DTC

           SET HDT=X

           SET OLD=J

RD1        SET DIC="^SC("

           SET DIC(0)="EFQ"

           SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS"")),$S(DIV="""":1,$P(^(0),""^"",15)=DIV:1,1:0)"

           READ !,"Select Clinic: ",X:DTIME

           IF "^"[X

               GOTO END

           IF X["?"

               WRITE !,"ENTER A CLINIC NAME OR 'ALL' TO CHECK ALL CLINICS"

 +1        SET X=$$UP^XLFSTR(X)

           IF X'="ALL"

               DO ^DIC

               KILL DIC

               IF Y<0

                   GOTO RD1

 +2        KILL DIC

           SET SDCL=$SELECT(X="ALL":"ALL",1:+Y)

+3

*** ERROR ***

SDST.m