SDCP ;BSN/GRR - CLINIC LIST ; 15 MAR 1999 4:10 PM ;
;;5.3;Scheduling;**140,171,187,354,1015**;Aug 13, 1993;Build 21
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
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 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) 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+12>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)
W ! D L("Location",19,$E(LOC,1,30)),L("Telephone",62,$S($D(^SC(SC,99)):^SC(SC,99),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
TOF W @IOF,?22,"CLINIC PROFILES AS OF: ",PDATE,! 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
SDCP ;BSN/GRR - CLINIC LIST ; 15 MAR 1999 4:10 PM ;
+1 ;;5.3;Scheduling;**140,171,187,354,1015**;Aug 13, 1993;Build 21
+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 SET END=0
IF '$DATA(DT)
DO DT^SDUTL
+2 SET Y=DT
DO DTS^SDUTL
SET PDATE=Y
SET SCN=0
DO TOF
IF 'VAUTC
GOTO SOME
+3 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
+4 GOTO END
+5 ;
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
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)
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+12>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 WRITE !
DO L("Location",19,$EXTRACT(LOC,1,30))
DO L("Telephone",62,$SELECT($DATA(^SC(SC,99)):^SC(SC,99),1:""))
+3 WRITE !
DO L("Days clinic meets",19,DAYS)
IF 'SDNO
SET Y=STDAT
IF STDAT'="UNKNOWN"
DO DTS^SDUTL
+4 DO L("Start date",62,$SELECT(STDAT="UNKNOWN":"UNKNOWN",1:Y))
+5 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"))
+6 WRITE !
DO L("Appt. length",19,LOP_" Minutes")
DO L("Variable length appts.",62,ALV)
+7 WRITE !
DO L("Stop Code",19,STCD)
DO L("Maximum overbooks per day",62,ODM)
+8 WRITE !
DO L("Credit Stop Code",19,SDCR)
DO L("Non-count clinic",62,$SELECT(SDCNT="Y":"YES",1:"NO"))
+9 WRITE !
DO L("Prohibit access",19,SDPR)
DO L("Maximum days for future booking",62,$GET(SDMX))
+10 IF PC]""
WRITE !
DO L("Principal clinic",19,PC)
+11 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
+12 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
+13 IF 'SDSC
WRITE !!,?4,"*** INVALID OR INACTIVE STOP CODE ASSIGNED TO THIS CLINIC ***"
+14 QUIT
+15 ;
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
TOF WRITE @IOF,?22,"CLINIC PROFILES AS OF: ",PDATE,!
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
