- SDCLAS0 ;ALB/TMP - Clinic Assignment List Select and Extract ; 22 MAR 1985
- ;;5.3;Scheduling;**32,115**;Aug 13, 1993
- SELECT W !!,"Do you want the report for active patients only" S %=1 D YN^DICN I %<0 G OUT
- I '% W !,"Respond (Y)es for a report of only patients with future appointments",!,"Respond (N)o for a report which also includes patients who are enrolled,",!," but have no future appointments" G SELECT
- S SDFAST='(%-1)
- SELECT1 W !!,"Sort by (C)linic or (S)top Code?: " R X:DTIME G:"^"[X OUT D:X?.E1"?" H1 S X=$E(X,1),X=$$UP^XLFSTR(X) G:"SC"'[X SELECT1 S SDSRT=X,SDSAV="" G:SDSRT="S" SEL1A
- SEL1 W !!,"Select Clinic: ",$S(SDSAV']"":"ALL// ",1:"") R X:DTIME Q:X["^" G:'$T OUT G:X["?" H2 I X="",SDSAV']"" S X="ALL"
- S X=$$UP^XLFSTR(X)
- I X="" S:$P(SDSAV,",",2)']""&($P(SDSAV,",",1)'["--") SDIFN=+SDSAV,SDSAV="" Q
- I X="ALL" S SDSAV="",SDIFN="ALL" Q
- I X["--" S SDSAV=SDSAV_X_"," G SEL1
- LOOK D ^DIC G:Y'>0 SEL1 K DIC("S") S SDSAV=SDSAV_+Y_"," G SEL1
- SEL1A K DIC("S") W !!,"Select Stop Code: ALL// " R X:DTIME Q:X["^" G:'$T OUT G:X["?" H3 I X="" S SDIFN="ALL" Q
- LOOK1 S DIC="^DIC(40.7,",DIC(0)="EFMQ" D ^DIC G:Y'>0 SEL1A S SDIFN=+Y
- Q
- OUT S X="^" Q
- EXT S (SDLAST,SDNEXT)="",U="^"
- F I=0:0 S I=$O(^DPT(DFN,"S",I)) Q:'I I $P(^DPT(DFN,"S",I,0),U,2)'["C",$P(^(0),U,2)'["N",+^DPT(DFN,"S",I,0)=SDIFN S:I'>SDTS SDLAST=I I I>SDTS S SDNEXT=I Q
- S ^UTILITY($J,"S",$E($P(^SC(SDIFN,0),U),1,30),SDIFN,$E($P(Y(0),U),1,20),DFN)=SDLAST_U_SDNEXT_U_$P(Y(1),U)_U_SDENR_U_SDACT_U_$P(Y(1),U,2)
- I SDACT S ^UTILITY($J,"SDACT",SDIFN)=^UTILITY($J,"SDACT",SDIFN)+1
- I 'SDACT S ^UTILITY($J,"SDENR",SDIFN)=^UTILITY($J,"SDENR",SDIFN)+1
- K SDACT,Y Q
- AEB F A=0:0 S A=$O(^DPT("AEB1",SDIFN,A)) Q:'A!(A>(SDTS_.9)) F A1=0:0 S A1=$O(^DPT("AEB1",SDIFN,A,A1)) Q:'A1 I '$D(^UTILITY($J,"PAT",SDIFN,A1)),$D(^DPT(A1,0)),$S('$D(^(.35)):1,'^(.35):1,1:0) S (SDENR,SDACT)=0 D AEB1
- Q
- AEB1 F A2=0:0 S A2=$O(^DPT("AEB1",SDIFN,A,A1,A2)) Q:'A2!($D(^UTILITY($J,"PAT",A1,SDIFN))) F A3=0:0 S A3=$O(^DPT("AEB1",SDIFN,A,A1,A2,A3)) Q:'A3 D AEB2
- Q
- AEB2 I $D(^DPT(A1,"DE",A2,1,A3,0)),+^(0)<(SDTS_.9) S X=+$P(^(0),"^",3) I X'<SDTS!('X) S SDACT=0,SDENR=1 D T2
- Q
- H1 W !!,"Enter C to select and sort by clinic or S to sort and select by a stop code" Q
- H2 W !!,"Valid responses:",!,?5,"A clinic name or abbreviation",!,?5,"A range of clinics separated by two dashes",!,?10,"(example: GEN MED--GEN MEDZ will report all clinics whose names start GEN MED)"
- W !,?5,"'ALL' to report all clinics",!,?5,"Hit return when done selecting clinics" G LOOK
- H3 W !!,"Enter a stop code or 'All' for all stop codes" G LOOK1
- T2 S DFN=A1,Y(1)=^DPT(A1,"DE",A2,1,A3,0),Y(0)=^DPT(A1,0)
- D SET1^SDCLAS I '$D(^UTILITY($J,"PAT"," ",DFN)) D MT^SDCLAS S ^UTILITY($J,"PAT"," ",DFN)=$P(Y(0),"^",9)_"^"_SDELIG_"^"_SDZIP_"^"_$P(Y(0),"^",3)_"^"_SDMT
- D EXT Q
- SPLIT S SD01=$P(SDZ,"--",1),SD02=$P(SDZ,"--",2) I SD01?1N.N G S1
- I $D(^SC("B",SD01)) S X=$O(^SC("B",SD01,0)) S:X>0 SDZ(X)=""
- S SDI=SD01 F II=0:0 S SDI=$O(^SC("B",SDI)) Q:SDI]SD02!(SDI="") S X=$O(^SC("B",SDI,0)) S:X>0 SDZ(X)=""
- K SD01,SD02,II,X,SDI Q
- S1 F II=SD01-1:0 S II=$O(^SC(II)) Q:'II!(II>SD02) S SDZ(II)=""
- K SD01,SD02,II Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCLAS0 3158 printed Jan 18, 2025@03:50:10 Page 2
- SDCLAS0 ;ALB/TMP - Clinic Assignment List Select and Extract ; 22 MAR 1985
- +1 ;;5.3;Scheduling;**32,115**;Aug 13, 1993
- SELECT WRITE !!,"Do you want the report for active patients only"
- SET %=1
- DO YN^DICN
- IF %<0
- GOTO OUT
- +1 IF '%
- WRITE !,"Respond (Y)es for a report of only patients with future appointments",!,"Respond (N)o for a report which also includes patients who are enrolled,",!," but have no future appointments"
- GOTO SELECT
- +2 SET SDFAST='(%-1)
- SELECT1 WRITE !!,"Sort by (C)linic or (S)top Code?: "
- READ X:DTIME
- if "^"[X
- GOTO OUT
- if X?.E1"?"
- DO H1
- SET X=$EXTRACT(X,1)
- SET X=$$UP^XLFSTR(X)
- if "SC"'[X
- GOTO SELECT1
- SET SDSRT=X
- SET SDSAV=""
- if SDSRT="S"
- GOTO SEL1A
- SEL1 WRITE !!,"Select Clinic: ",$SELECT(SDSAV']"":"ALL// ",1:"")
- READ X:DTIME
- if X["^"
- QUIT
- if '$TEST
- GOTO OUT
- if X["?"
- GOTO H2
- IF X=""
- IF SDSAV']""
- SET X="ALL"
- +1 SET X=$$UP^XLFSTR(X)
- +2 IF X=""
- if $PIECE(SDSAV,",",2)']""&($PIECE(SDSAV,",",1)'["--")
- SET SDIFN=+SDSAV
- SET SDSAV=""
- QUIT
- +3 IF X="ALL"
- SET SDSAV=""
- SET SDIFN="ALL"
- QUIT
- +4 IF X["--"
- SET SDSAV=SDSAV_X_","
- GOTO SEL1
- LOOK DO ^DIC
- if Y'>0
- GOTO SEL1
- KILL DIC("S")
- SET SDSAV=SDSAV_+Y_","
- GOTO SEL1
- SEL1A KILL DIC("S")
- WRITE !!,"Select Stop Code: ALL// "
- READ X:DTIME
- if X["^"
- QUIT
- if '$TEST
- GOTO OUT
- if X["?"
- GOTO H3
- IF X=""
- SET SDIFN="ALL"
- QUIT
- LOOK1 SET DIC="^DIC(40.7,"
- SET DIC(0)="EFMQ"
- DO ^DIC
- if Y'>0
- GOTO SEL1A
- SET SDIFN=+Y
- +1 QUIT
- OUT SET X="^"
- QUIT
- EXT SET (SDLAST,SDNEXT)=""
- SET U="^"
- +1 FOR I=0:0
- SET I=$ORDER(^DPT(DFN,"S",I))
- if 'I
- QUIT
- IF $PIECE(^DPT(DFN,"S",I,0),U,2)'["C"
- IF $PIECE(^(0),U,2)'["N"
- IF +^DPT(DFN,"S",I,0)=SDIFN
- if I'>SDTS
- SET SDLAST=I
- IF I>SDTS
- SET SDNEXT=I
- QUIT
- +2 SET ^UTILITY($JOB,"S",$EXTRACT($PIECE(^SC(SDIFN,0),U),1,30),SDIFN,$EXTRACT($PIECE(Y(0),U),1,20),DFN)=SDLAST_U_SDNEXT_U_$PIECE(Y(1),U)_U_SDENR_U_SDACT_U_$PIECE(Y(1),U,2)
- +3 IF SDACT
- SET ^UTILITY($JOB,"SDACT",SDIFN)=^UTILITY($JOB,"SDACT",SDIFN)+1
- +4 IF 'SDACT
- SET ^UTILITY($JOB,"SDENR",SDIFN)=^UTILITY($JOB,"SDENR",SDIFN)+1
- +5 KILL SDACT,Y
- QUIT
- AEB FOR A=0:0
- SET A=$ORDER(^DPT("AEB1",SDIFN,A))
- if 'A!(A>(SDTS_.9))
- QUIT
- FOR A1=0:0
- SET A1=$ORDER(^DPT("AEB1",SDIFN,A,A1))
- if 'A1
- QUIT
- IF '$DATA(^UTILITY($JOB,"PAT",SDIFN,A1))
- IF $DATA(^DPT(A1,0))
- IF $SELECT('$DATA(^(.35)):1,'^(.35):1,1:0)
- SET (SDENR,SDACT)=0
- DO AEB1
- +1 QUIT
- AEB1 FOR A2=0:0
- SET A2=$ORDER(^DPT("AEB1",SDIFN,A,A1,A2))
- if 'A2!($DATA(^UTILITY($JOB,"PAT",A1,SDIFN)))
- QUIT
- FOR A3=0:0
- SET A3=$ORDER(^DPT("AEB1",SDIFN,A,A1,A2,A3))
- if 'A3
- QUIT
- DO AEB2
- +1 QUIT
- AEB2 IF $DATA(^DPT(A1,"DE",A2,1,A3,0))
- IF +^(0)<(SDTS_.9)
- SET X=+$PIECE(^(0),"^",3)
- IF X'<SDTS!('X)
- SET SDACT=0
- SET SDENR=1
- DO T2
- +1 QUIT
- H1 WRITE !!,"Enter C to select and sort by clinic or S to sort and select by a stop code"
- QUIT
- H2 WRITE !!,"Valid responses:",!,?5,"A clinic name or abbreviation",!,?5,"A range of clinics separated by two dashes",!,?10,"(example: GEN MED--GEN MEDZ will report all clinics whose names start GEN MED)"
- +1 WRITE !,?5,"'ALL' to report all clinics",!,?5,"Hit return when done selecting clinics"
- GOTO LOOK
- H3 WRITE !!,"Enter a stop code or 'All' for all stop codes"
- GOTO LOOK1
- T2 SET DFN=A1
- SET Y(1)=^DPT(A1,"DE",A2,1,A3,0)
- SET Y(0)=^DPT(A1,0)
- +1 DO SET1^SDCLAS
- IF '$DATA(^UTILITY($JOB,"PAT"," ",DFN))
- DO MT^SDCLAS
- SET ^UTILITY($JOB,"PAT"," ",DFN)=$PIECE(Y(0),"^",9)_"^"_SDELIG_"^"_SDZIP_"^"_$PIECE(Y(0),"^",3)_"^"_SDMT
- +2 DO EXT
- QUIT
- SPLIT SET SD01=$PIECE(SDZ,"--",1)
- SET SD02=$PIECE(SDZ,"--",2)
- IF SD01?1N.N
- GOTO S1
- +1 IF $DATA(^SC("B",SD01))
- SET X=$ORDER(^SC("B",SD01,0))
- if X>0
- SET SDZ(X)=""
- +2 SET SDI=SD01
- FOR II=0:0
- SET SDI=$ORDER(^SC("B",SDI))
- if SDI]SD02!(SDI="")
- QUIT
- SET X=$ORDER(^SC("B",SDI,0))
- if X>0
- SET SDZ(X)=""
- +3 KILL SD01,SD02,II,X,SDI
- QUIT
- S1 FOR II=SD01-1:0
- SET II=$ORDER(^SC(II))
- if 'II!(II>SD02)
- QUIT
- SET SDZ(II)=""
- +1 KILL SD01,SD02,II
- QUIT