- 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
