SDCP ;BSN/GRR - CLINIC LIST ;15 MAR 1999 4:10 PM
;;5.3;Scheduling;**140,171,187,354,622,635,641**;Aug 13, 1993;Build 4
D ASK2^SDDIV G:Y<0 END S VAUTNI=1 D CLINIC^VAUTOMA G:Y<0 END
QUE N ZTSAVE F Y="VAUTD","VAUTD(","VAUTC","VAUTC(" S ZTSAVE(Y)=""
D EN^XUTMDEVQ("START^SDCP","Clinic Profile",.ZTSAVE) Q
;
START ;Print report
; SD*5.3*622 - SDPRTTOF helps prevent double printing of Header
N SDPRTTOF S SDPRTTOF=1
S END=0 D:'$D(DT) DT^SDUTL
S Y=DT D DTS^SDUTL S PDATE=Y,SCN=0 D TOF G:'VAUTC SOME
F S SCN=$O(^SC("B",SCN)) Q:SCN=""!(END) S SC=$O(^SC("B",SCN,0)) D:$$CHECK() SET0,SETSL,PRT
G END
;
SOME F S SCN=$O(VAUTC(SCN)) Q:SCN=""!(END) S SC=+VAUTC(SCN) D:$$CHECK() SET0,SETSL,PRT
G END
;
END W ! I $E(IOST)="C",'$G(END,1) N DIR S DIR(0)="E" D ^DIR
K ABBR,ALV,C,DAYS,DIC,DIPH,DOW,END,HCDB,I,J,L,LOC,LOP,M,NAME,ODM,PC,PDATE,POP,SC,SCSC,SDSC,SDMX,SDNO,SDNO,SDC,SDCR,SCSC,SCN,SDIN,SDPR,SDRE,STCD,STDAT,X,Y,SD,SDCNT,VAUTC,VAUTD,VAUTNI,STRING,SDPTI Q
;
SET0 S STRING=^SC(SC,0)
S NAME=$P(STRING,U,1),ABBR=$P(STRING,U,2),LOC=$P(STRING,U,11),(STCD,SDSC)=$P(STRING,U,7),SDCR=$P(STRING,U,18),SDCNT=$P(STRING,U,17)
S:$D(^SC(SC,"SDP")) SDMX=$P(^SC(SC,"SDP"),U,2) S SDPTI=$G(^SC(SC,"PA")) Q
;
SETSL S (LOP,HCDB,ALV,PC,ODM,DIPH,STDAT,STRING)="",STCD=$S(STCD="":" ",1:STCD),STCD=$S('$D(^DIC(40.7,+STCD,0)):"",1:$P(^(0),U,2)),SDSC=$S($D(^DIC(40.7,+SDSC,0)):'$P(^(0),U,3)!($P(^(0),U,3)>DT),1:0)
S SDPR=$S('$D(^SC(SC,"SDPROT")):"NO",'$L($P(^("SDPROT"),U)):"NO",1:"YES")
S SDCR=$S(SDCR="":" ",1:SDCR),SDCR=$S('$D(^DIC(40.7,+SDCR,0)):"",1:$P(^(0),U,2))
I $D(^SC(SC,"SL")) S STRING=^("SL"),LOP=$P(STRING,U,1),HCDB=$P(STRING,U,3),ALV=$S($P(STRING,U,2)["V":"YES",1:"NO")
I S PC=$S($P(STRING,U,5)]"":$P(^SC($P(STRING,U,5),0),U,1),1:""),ODM=$P(STRING,U,7),DIPH=$S($P(STRING,U,6)=4:15,$P(STRING,U,6)=3:20,$P(STRING,U,6)=1:60,$P(STRING,U,6)=2:30,1:10)
S STDAT=$O(^SC(SC,"T",0)) S:STDAT<1 STDAT="UNKNOWN"
K DOW F L=0:1:6 F M=DT-.1:0 S M=$O(^SC(SC,"T"_L,M)) Q:M="" I $D(^(M,1)) S:^(1)]"" DOW(L+1)="" Q:^(1)]"" K DOW(L+1)
F L=DT-.1:0 S L=$O(^SC(SC,"T",L)) Q:L="" S X=L D DW^%DTC I '$D(DOW(Y+1)),$D(^SC(SC,"OST",L,1)),^(1)["[" S DOW(Y+1)=""
S DAYS="" F M=1:1:7 I $D(DOW(M)) S DAYS=DAYS_$S(DAYS'="":",",1:"")_$P("SU^MO^TU^WE^TH^FR^SA",U,M)
Q
;
L(SDT,SDCOL,SDVAL) ;Print field label
;Input: SDT=field label
;Input: SDCOL=column to line up to
;Input: SDVAL=field value
W ?(SDCOL-$L(SDT)-2),SDT,": ",SDVAL Q
;
PRT I $Y+13>IOSL D:IOSL<25 SEEND:$E(IOST,1,2)="C-" Q:END D TOF
S SDNO="" W ! D L("Clinic",19,NAME),L("Abbr.",62,ABBR)
S SDPRTTOF=1 ; SD*5.3*622 - SDPRTTOF helps prevent double Headers
; SD*5.3*641 - get 1st piece of 99 node
W ! D L("Location",19,$E(LOC,1,30)),L("Telephone",62,$S($D(^SC(SC,99)):$P($G(^SC(SC,99)),U),1:""))
; SD*5.3*622 - add new field telephone extension
W ! D L("Telephone Ext.",19,$S($D(^SC(SC,99.1)):^SC(SC,99.1),1:""))
; SD*5.3*635 - add new fields #60-62
N DIWL,DIWF K ^UTILITY($J,"W") S DIWL=1,DIWF="C55" S X=$P(SDPTI,U) D ^DIWP
W ! D L("Pat Friendly Name",19,$G(^UTILITY($J,"W",1,1,0)))
I $G(^UTILITY($J,"W",1,2,0))'="" W ! D L(" ",19,$G(^UTILITY($J,"W",1,2,0)))
K ^UTILITY($J,"W") W ! D L("Direct Pat Schlng",19,$S($P(SDPTI,U,2)="N":"NO",$P(SDPTI,U,2)="Y":"YES",1:""))
D L("Display Clin Appt To Patients",62,$S($P(SDPTI,U,3)="N":"NO",$P(SDPTI,U,3)="Y":"YES",1:""))
W ! D L("Days clinic meets",19,DAYS) I 'SDNO S Y=STDAT D:STDAT'="UNKNOWN" DTS^SDUTL
D L("Start date",62,$S(STDAT="UNKNOWN":"UNKNOWN",1:Y))
W ! D L("Increments",19,DIPH_" Minutes"),L("Hour display begins",62,$S(HCDB="":"8 AM",HCDB<13:HCDB_" AM",1:HCDB-12_" PM"))
W ! D L("Appt. length",19,LOP_" Minutes"),L("Variable length appts.",62,ALV)
W ! D L("Stop Code",19,STCD),L("Maximum overbooks per day",62,ODM)
W ! D L("Credit Stop Code",19,SDCR),L("Non-count clinic",62,$S(SDCNT="Y":"YES",1:"NO"))
W ! D L("Prohibit access",19,SDPR),L("Maximum days for future booking",62,$G(SDMX))
I PC]"" W ! D L("Principal clinic",19,PC)
I $D(^SC(SC,"I")) S SDRE=+$P(^("I"),U,2),SDIN=+^("I") I SDRE'=SDIN D:SDIN'>DT&(SDRE=0!(SDRE>DT)) INACT
I 'SDNO,$D(SDIN),SDIN>DT,SDRE'=SDIN W !!,?4,"**** Clinic will be inactive ",$S(SDRE:"from ",1:"as of ") S Y=SDIN D DTS^SDUTL W Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"")," ****" K SDIN,SDRE
I 'SDSC W !!,?4,"*** INVALID OR INACTIVE STOP CODE ASSIGNED TO THIS CLINIC ***"
Q
;
INACT S Y=SDIN D DTS^SDUTL W !!,?4,"**** Clinic is inactive ",$S(SDRE:"from ",1:"as of "),Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"")," ****" K SDIN,SDRE S SDNO=1
Q
;
SEEND W ! N DIR S DIR(0)="E" D ^DIR S END=Y'=1 Q:END
; SD*5.3*622 - SDPRTTOF helps prevent double printing of Header
TOF I SDPRTTOF W @IOF,?22,"CLINIC PROFILES AS OF: ",PDATE,! S SDPRTTOF=0 Q
;
CHECK() ;Check location for inclusion
I $D(^SC(SC,0)),($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) Q 1
Q 0
;
;
PAUSE(LINE) ;
N Y S Y=1
I $E(IOST,1,2)="C-",(LINE+5)>IOSL D PAUSE^VALM1 S LINE=0
S LINE=LINE+1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCP 5073 printed Sep 23, 2025@20:26:03 Page 2
SDCP ;BSN/GRR - CLINIC LIST ;15 MAR 1999 4:10 PM
+1 ;;5.3;Scheduling;**140,171,187,354,622,635,641**;Aug 13, 1993;Build 4
+2 DO ASK2^SDDIV
if Y<0
GOTO END
SET VAUTNI=1
DO CLINIC^VAUTOMA
if Y<0
GOTO END
QUE NEW ZTSAVE
FOR Y="VAUTD","VAUTD(","VAUTC","VAUTC("
SET ZTSAVE(Y)=""
+1 DO EN^XUTMDEVQ("START^SDCP","Clinic Profile",.ZTSAVE)
QUIT
+2 ;
START ;Print report
+1 ; SD*5.3*622 - SDPRTTOF helps prevent double printing of Header
+2 NEW SDPRTTOF
SET SDPRTTOF=1
+3 SET END=0
if '$DATA(DT)
DO DT^SDUTL
+4 SET Y=DT
DO DTS^SDUTL
SET PDATE=Y
SET SCN=0
DO TOF
if 'VAUTC
GOTO SOME
+5 FOR
SET SCN=$ORDER(^SC("B",SCN))
if SCN=""!(END)
QUIT
SET SC=$ORDER(^SC("B",SCN,0))
if $$CHECK()
DO SET0
DO SETSL
DO PRT
+6 GOTO END
+7 ;
SOME FOR
SET SCN=$ORDER(VAUTC(SCN))
if SCN=""!(END)
QUIT
SET SC=+VAUTC(SCN)
if $$CHECK()
DO SET0
DO SETSL
DO PRT
+1 GOTO END
+2 ;
END WRITE !
IF $EXTRACT(IOST)="C"
IF '$GET(END,1)
NEW DIR
SET DIR(0)="E"
DO ^DIR
+1 KILL ABBR,ALV,C,DAYS,DIC,DIPH,DOW,END,HCDB,I,J,L,LOC,LOP,M,NAME,ODM,PC,PDATE,POP,SC,SCSC,SDSC,SDMX,SDNO,SDNO,SDC,SDCR,SCSC,SCN,SDIN,SDPR,SDRE,STCD,STDAT,X,Y,SD,SDCNT,VAUTC,VAUTD,VAUTNI,STRING,SDPTI
QUIT
+2 ;
SET0 SET STRING=^SC(SC,0)
+1 SET NAME=$PIECE(STRING,U,1)
SET ABBR=$PIECE(STRING,U,2)
SET LOC=$PIECE(STRING,U,11)
SET (STCD,SDSC)=$PIECE(STRING,U,7)
SET SDCR=$PIECE(STRING,U,18)
SET SDCNT=$PIECE(STRING,U,17)
+2 if $DATA(^SC(SC,"SDP"))
SET SDMX=$PIECE(^SC(SC,"SDP"),U,2)
SET SDPTI=$GET(^SC(SC,"PA"))
QUIT
+3 ;
SETSL SET (LOP,HCDB,ALV,PC,ODM,DIPH,STDAT,STRING)=""
SET STCD=$SELECT(STCD="":" ",1:STCD)
SET STCD=$SELECT('$DATA(^DIC(40.7,+STCD,0)):"",1:$PIECE(^(0),U,2))
SET SDSC=$SELECT($DATA(^DIC(40.7,+SDSC,0)):'$PIECE(^(0),U,3)!($PIECE(^(0),U,3)>DT),1:0)
+1 SET SDPR=$SELECT('$DATA(^SC(SC,"SDPROT")):"NO",'$LENGTH($PIECE(^("SDPROT"),U)):"NO",1:"YES")
+2 SET SDCR=$SELECT(SDCR="":" ",1:SDCR)
SET SDCR=$SELECT('$DATA(^DIC(40.7,+SDCR,0)):"",1:$PIECE(^(0),U,2))
+3 IF $DATA(^SC(SC,"SL"))
SET STRING=^("SL")
SET LOP=$PIECE(STRING,U,1)
SET HCDB=$PIECE(STRING,U,3)
SET ALV=$SELECT($PIECE(STRING,U,2)["V":"YES",1:"NO")
+4 IF $TEST
SET PC=$SELECT($PIECE(STRING,U,5)]"":$PIECE(^SC($PIECE(STRING,U,5),0),U,1),1:"")
SET ODM=$PIECE(STRING,U,7)
SET DIPH=$SELECT($PIECE(STRING,U,6)=4:15,$PIECE(STRING,U,6)=3:20,$PIECE(STRING,U,6)=1:60,$PIECE(STRING,U,6)=2:30,1:10)
+5 SET STDAT=$ORDER(^SC(SC,"T",0))
if STDAT<1
SET STDAT="UNKNOWN"
+6 KILL DOW
FOR L=0:1:6
FOR M=DT-.1:0
SET M=$ORDER(^SC(SC,"T"_L,M))
if M=""
QUIT
IF $DATA(^(M,1))
if ^(1)]""
SET DOW(L+1)=""
if ^(1)]""
QUIT
KILL DOW(L+1)
+7 FOR L=DT-.1:0
SET L=$ORDER(^SC(SC,"T",L))
if L=""
QUIT
SET X=L
DO DW^%DTC
IF '$DATA(DOW(Y+1))
IF $DATA(^SC(SC,"OST",L,1))
IF ^(1)["["
SET DOW(Y+1)=""
+8 SET DAYS=""
FOR M=1:1:7
IF $DATA(DOW(M))
SET DAYS=DAYS_$SELECT(DAYS'="":",",1:"")_$PIECE("SU^MO^TU^WE^TH^FR^SA",U,M)
+9 QUIT
+10 ;
L(SDT,SDCOL,SDVAL) ;Print field label
+1 ;Input: SDT=field label
+2 ;Input: SDCOL=column to line up to
+3 ;Input: SDVAL=field value
+4 WRITE ?(SDCOL-$LENGTH(SDT)-2),SDT,": ",SDVAL
QUIT
+5 ;
PRT IF $Y+13>IOSL
if IOSL<25
if $EXTRACT(IOST,1,2)="C-"
DO SEEND
if END
QUIT
DO TOF
+1 SET SDNO=""
WRITE !
DO L("Clinic",19,NAME)
DO L("Abbr.",62,ABBR)
+2 ; SD*5.3*622 - SDPRTTOF helps prevent double Headers
SET SDPRTTOF=1
+3 ; SD*5.3*641 - get 1st piece of 99 node
+4 WRITE !
DO L("Location",19,$EXTRACT(LOC,1,30))
DO L("Telephone",62,$SELECT($DATA(^SC(SC,99)):$PIECE($GET(^SC(SC,99)),U),1:""))
+5 ; SD*5.3*622 - add new field telephone extension
+6 WRITE !
DO L("Telephone Ext.",19,$SELECT($DATA(^SC(SC,99.1)):^SC(SC,99.1),1:""))
+7 ; SD*5.3*635 - add new fields #60-62
+8 NEW DIWL,DIWF
KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWF="C55"
SET X=$PIECE(SDPTI,U)
DO ^DIWP
+9 WRITE !
DO L("Pat Friendly Name",19,$GET(^UTILITY($JOB,"W",1,1,0)))
+10 IF $GET(^UTILITY($JOB,"W",1,2,0))'=""
WRITE !
DO L(" ",19,$GET(^UTILITY($JOB,"W",1,2,0)))
+11 KILL ^UTILITY($JOB,"W")
WRITE !
DO L("Direct Pat Schlng",19,$SELECT($PIECE(SDPTI,U,2)="N":"NO",$PIECE(SDPTI,U,2)="Y":"YES",1:""))
+12 DO L("Display Clin Appt To Patients",62,$SELECT($PIECE(SDPTI,U,3)="N":"NO",$PIECE(SDPTI,U,3)="Y":"YES",1:""))
+13 WRITE !
DO L("Days clinic meets",19,DAYS)
IF 'SDNO
SET Y=STDAT
if STDAT'="UNKNOWN"
DO DTS^SDUTL
+14 DO L("Start date",62,$SELECT(STDAT="UNKNOWN":"UNKNOWN",1:Y))
+15 WRITE !
DO L("Increments",19,DIPH_" Minutes")
DO L("Hour display begins",62,$SELECT(HCDB="":"8 AM",HCDB<13:HCDB_" AM",1:HCDB-12_" PM"))
+16 WRITE !
DO L("Appt. length",19,LOP_" Minutes")
DO L("Variable length appts.",62,ALV)
+17 WRITE !
DO L("Stop Code",19,STCD)
DO L("Maximum overbooks per day",62,ODM)
+18 WRITE !
DO L("Credit Stop Code",19,SDCR)
DO L("Non-count clinic",62,$SELECT(SDCNT="Y":"YES",1:"NO"))
+19 WRITE !
DO L("Prohibit access",19,SDPR)
DO L("Maximum days for future booking",62,$GET(SDMX))
+20 IF PC]""
WRITE !
DO L("Principal clinic",19,PC)
+21 IF $DATA(^SC(SC,"I"))
SET SDRE=+$PIECE(^("I"),U,2)
SET SDIN=+^("I")
IF SDRE'=SDIN
if SDIN'>DT&(SDRE=0!(SDRE>DT))
DO INACT
+22 IF 'SDNO
IF $DATA(SDIN)
IF SDIN>DT
IF SDRE'=SDIN
WRITE !!,?4,"**** Clinic will be inactive ",$SELECT(SDRE:"from ",1:"as of ")
SET Y=SDIN
DO DTS^SDUTL
WRITE Y
SET Y=SDRE
if Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" to "_Y,1:"")," ****"
KILL SDIN,SDRE
+23 IF 'SDSC
WRITE !!,?4,"*** INVALID OR INACTIVE STOP CODE ASSIGNED TO THIS CLINIC ***"
+24 QUIT
+25 ;
INACT SET Y=SDIN
DO DTS^SDUTL
WRITE !!,?4,"**** Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),Y
SET Y=SDRE
if Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" to "_Y,1:"")," ****"
KILL SDIN,SDRE
SET SDNO=1
+1 QUIT
+2 ;
SEEND WRITE !
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET END=Y'=1
if END
QUIT
+1 ; SD*5.3*622 - SDPRTTOF helps prevent double printing of Header
TOF IF SDPRTTOF
WRITE @IOF,?22,"CLINIC PROFILES AS OF: ",PDATE,!
SET SDPRTTOF=0
QUIT
+1 ;
CHECK() ;Check location for inclusion
+1 IF $DATA(^SC(SC,0))
IF ($PIECE(^(0),U,3)="C")
IF $SELECT(VAUTD:1,$DATA(VAUTD(+$PIECE(^(0),U,15))):1,'$PIECE(^(0),U,15)&($DATA(VAUTD($ORDER(^DG(40.8,0))))):1,1:0)
QUIT 1
+2 QUIT 0
+3 ;
+4 ;
PAUSE(LINE) ;
+1 NEW Y
SET Y=1
+2 IF $EXTRACT(IOST,1,2)="C-"
IF (LINE+5)>IOSL
DO PAUSE^VALM1
SET LINE=0
+3 SET LINE=LINE+1
+4 QUIT Y
