- SDUNC ;MAN/GRR - RESTORE CLINIC AVAILABILITY ; 24 JUL 2003 10:08 am
- ;;5.3;Scheduling;**79,303,380,452,1006,1015**;Aug 13, 1993;Build 21
- ;IHS/ANMC/LJF 8/18/2000 added DIC("W") to warn if clinic inactivated
- ; 11/30/2000 changed $N to $O
- ; 12/13/2000 added code for 10 hour clinic displays
- ; 12/18/2002 added check so only onwers can restore clinic
- ;IHS/OIT/LJF 06/28/2006 PATCH 1006 if clinic pattern was deleted by a future inactivation, cannot restore
- ;
- ;D DT^DICRW S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") Q:"^"[X G:Y<0 SDUNC Q:'$D(^SC(+Y,"SL")) ;IHS/ANMC/LJF 8/18/2000
- D DT^DICRW S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: ",DIC("W")=$$INACTMSG^BSDU D ^DIC K DIC("S"),DIC("A") Q:"^"[X G:Y<0 SDUNC Q:'$D(^SC(+Y,"SL")) ;IHS/ANMC/LJF 8/18/2000
- ;1/9/2003 WAR per P46,LJF37
- I '$$OWNER^BSDU(+Y,+$G(DUZ)) D MSG^BDGF("You are NOT an owner of this clinic. Please select again.",2,1) G SDUNC ;IHS/ANMC/LJF 12/18/2002
- I $D(^SC(+Y,0)) ;IHS/ANMC/LJF 12/18/2002 restoring naked reference
- S SC=+Y,SL=^("SL") ;NAKED REFERENCE - ^SC(IFN,"SL")
- N SDRES S SDRES=$$CLNCK^SDUTL2(SC,1)
- I 'SDRES W !,?5,"Clinic MUST be corrected before continuing." G SDUNC
- S %DT="AEXF",%DT("A")="RESTORE '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT Q:Y<0
- S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S(%:%,1:8)
- K SDIN,SDIN1,SDRE,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDIN D DTS^SDUTL S SDIN1=Y,Y=SDRE D DTS^SDUTL S SDRE1=Y
- I $S('$D(SDIN):0,'SDIN:0,SDIN>CDATE:0,SDRE'>CDATE&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S(SDRE:"from ",1:"as of "),SDIN1,$S(SDRE:" to "_SDRE1,1:"") G SDUNC
- K SDIN,SDIN1,SDRE,SDRE1 G:'$D(^SC(SC,"ST",SD,1)) NOWAY
- I $D(^SC(SC,"ST",SD,1)),^(1)'["CANCELLED"&(^(1)'["X") G NOWAY
- I $D(^SC(SC,"ST",SD,9)) I $D(^SC(SC,"OST",SD,1)) D FIX Q:^SC(SC,"ST",SD,1)["X"&('$D(SDFR1)) S ^SC(SC,"ST",SD,1)=HOLD K:^(1)'["X" ^SC(SC,"ST",SD,"CAN") W !,"RESTORED!",*7 D CHK Q
- I $D(^SC(SC,"ST",SD,9)),'$D(^SC(SC,"OST",SD,1)) G ERRM^SDUNC1
- ;
- ;IHS/OIT/LJF 06/28/2006 PATCH 1006
- ;D B Q:^SC(SC,"ST",SD,1)["X"&('$D(SDFR1)) S ^SC(SC,"ST",SD,0)=SD,^SC(SC,"ST",SD,1)=DH G N
- D B Q:^SC(SC,"ST",SD,1)["X"&('$D(SDFR1))
- I '$D(DH) W !!,"**** This date CANNOT be RESTORED. ****",!,"Clinic has been INACTIVATED and default slots have been removed.",!,"You must enter the AVAILABILITY again under Set Up A Clinic." Q ;new code
- S ^SC(SC,"ST",SD,0)=SD,^SC(SC,"ST",SD,1)=DH G N
- ;IHS/OIT/LJF 06/28/2006 end of PATCH 1006 changes
- ;
- Q:^SC(SC,"ST",SD,1)["X"&('$D(SDFR1)) S ^SC(SC,"ST",SD,0)=SD,^SC(SC,"ST",SD,1)=DH G N
- NOWAY W !,*7,"CLINIC HAS NOT BEEN CANCELLED FOR THAT DATE, SO IT CANNOT BE RESTORED",*7 G SDUNC
- NOPAT W !,*7,"NO UPCOMING OR INDEFINITE APPOINTMENT PATTERN EXISTS FOR DAY OF WEEK,",!,"CREATE 'AVAILABILITY' PATTERN THRU 'CLINIC SETUP', THEN RESTORE AGAIN",*7 G SDUNC
- B S X=SD D DOW^SDM0 S DOW=Y,SS=$O(^SC(SC,"T"_Y,X)) I SS'="",$D(^(SS,1)),^(1)]"" S DH=$P("SU^MO^TU^WE^TH^FR^SA","^",DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),DO=X+1,DA(1)=SC,HOLD=DH D FIX2
- Q
- N I '$F(^SC(SC,"ST",SD,1),"[") K ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDUNC
- K:^SC(SC,"ST",SD,1)'["X" ^SC(SC,"ST",SD,"CAN") W !,"RESTORED!",*7 D CHK Q
- FIX I ^SC(SC,"ST",SD,1)["X" S SDREST=^SC(SC,"OST",SD,1) D SEL Q
- S HOLD=^SC(SC,"OST",SD,1)
- Q
- CHK F N1=SD:0 S N1=$O(^SC(SC,"S",N1)) Q:'N1!(N1\1-SD) I $D(^SC(SC,"S",N1,"MES")) D KMES I $D(SDFR1),'$D(^("MES")) Q
- Q
- FIX2 Q:^SC(SC,"ST",SD,1)'["X"
- S SDREST=DH D SEL Q:'$D(SDFR1) S DH=HOLD
- Q
- SEL K SDFR1 Q:'$D(^SC(SC,"SL")) S SL=^("SL"),%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S(%:%,1:8)
- W !,"Clinic has been cancelled for the following periods:",!
- ;
- ;IHS/ANMC/LJF 11/30/2000 $N->$O
- ;K SDTEMP,SDZZ S SDZZ=0 F I=SD:0 S I=$N(^SC(SC,"SDCAN",I)) Q:I'>0!(I\1-SD) S SDZZ=SDZZ+1,X=I D TM S SDFR=X,SDFRX=X1,X="."_$P(^(I,0),"^",2) D TM S SDTO=X,SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_SDTO,SDZZ(SDZZ)=SDFRX_"-"_X1
- K SDTEMP,SDZZ S SDZZ=0 F I=SD:0 S I=$O(^SC(SC,"SDCAN",I)) Q:I'>0!(I\1-SD) S SDZZ=SDZZ+1,X=I D TM S SDFR=X,SDFRX=X1,X="."_$P(^(I,0),"^",2) D TM S SDTO=X,SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_SDTO,SDZZ(SDZZ)=SDFRX_"-"_X1
- ;F I=SD:0 S I=$N(^SC(SC,"S",I)) Q:I'>0!(I\1-SD) I $D(^SC(SC,"S",I,"MES")),'$D(^SC(SC,"SDCAN",I)) S X=I D TM S SDFRX=X1,SDFR=X,X="."_$E(^SC(SC,"S",I,"MES"),17,20) D TM S SDZZ=SDZZ+1,SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_X,SDZZ(SDZZ)=SDFRX_"-"_X1
- F I=SD:0 S I=$O(^SC(SC,"S",I)) Q:I'>0!(I\1-SD) I $D(^SC(SC,"S",I,"MES")),'$D(^SC(SC,"SDCAN",I)) S X=I D TM S SDFRX=X1,SDFR=X,X="."_$E(^SC(SC,"S",I,"MES"),17,20) D TM S SDZZ=SDZZ+1,SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_X,SDZZ(SDZZ)=SDFRX_"-"_X1
- ;F I1=0:0 S I1=$N(SDZZ(I1)) Q:I1'>0 S I=SDTEMP(SDZZ(I1)) W !,?9,"(",$J(I1,2),") ","From: ",$J($P(I,"^",1),8)," To: ",$J($P(I,"^",2),8)
- F I1=0:0 S I1=$O(SDZZ(I1)) Q:I1'>0 S I=SDTEMP(SDZZ(I1)) W !,?9,"(",$J(I1,2),") ","From: ",$J($P(I,"^",1),8)," To: ",$J($P(I,"^",2),8)
- ;
- A K SDFRX,X1,SDFR,SDTO R !!,"RESTORE WHICH PERIOD?: ",X:DTIME Q:"^"[X
- I X?1"?".E W !,"Enter the # that precedes the time period you want to restore." G A
- S SDR=X I $D(SDZZ(SDR)),$D(SDTEMP(SDZZ(SDR))) W " ",$P(SDTEMP(SDZZ(SDR)),"^",1)," - ",$P(SDTEMP(SDZZ(SDR)),"^",2) G ROK
- W !,*7,"INVALID CHOICE, TRY AGAIN" G A
- ROK S X=$P(SDZZ(SDR),"-",1) D TC S FR=X,SDBEG=%+SI+SI,X=$P(SDZZ(SDR),"-",2) D TC S TO=X,SDEND=%+SI+SI
- S SDFR1=CDATE+(FR/10000) K SDTEMP,SDZZ,SDR
- ;S HOLD=^SC(SC,"ST",SD,1),HOLD=$E(HOLD,1,SDBEG-1)_$E(SDREST,SDBEG,SDEND)_$E(HOLD,SDEND+1,80) K ^SC(SC,"SDCAN",SDFR1) I $D(^SC(SC,"SDCAN",0)) S CNT=$P(^(0),U,4),CNT=$S(CNT>0:CNT-1,1:0),^(0)=$P(^(0),U,1,3)_U_CNT K CNT ;IHS/ANMC/LJF 12/13/2000
- S HOLD=^SC(SC,"ST",SD,1),HOLD=$E(HOLD,1,SDBEG-1)_$E(SDREST,SDBEG,SDEND)_$E(HOLD,SDEND+1,132) K ^SC(SC,"SDCAN",SDFR1) I $D(^SC(SC,"SDCAN",0)) S CNT=$P(^(0),U,4),CNT=$S(CNT>0:CNT-1,1:0),^(0)=$P(^(0),U,1,3)_U_CNT K CNT ;IHS/ANMC/LJF 12/13/2000
- I HOLD'["[" S I5=$F(HOLD,"|"),HOLD=$E(HOLD,1,(I5-2))_"["_$E(HOLD,I5,999) K I5
- K SDBEG,SDEND,SDANS,SI,STARTDAY,FR,TO Q
- KMES I '$D(SDFR1) K ^("MES") Q ;NAKED REFERENCE - ^SC(IFN,"S",DATE,"MES")
- I $D(SDFR1),N1=SDFR1 K ^("MES") Q ;NAKED REFERENCE - ^SC(IFN,"S",DATE,"MES")
- Q
- TC S %=$E(X,3,4),%=X\100-STARTDAY*SI+(%*SI\60)*2
- Q
- TM S X=$E($P(X,".",2)_"0000",1,4),X1=X,%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
- SDUNC ;MAN/GRR - RESTORE CLINIC AVAILABILITY ; 24 JUL 2003 10:08 am
- +1 ;;5.3;Scheduling;**79,303,380,452,1006,1015**;Aug 13, 1993;Build 21
- +2 ;IHS/ANMC/LJF 8/18/2000 added DIC("W") to warn if clinic inactivated
- +3 ; 11/30/2000 changed $N to $O
- +4 ; 12/13/2000 added code for 10 hour clinic displays
- +5 ; 12/18/2002 added check so only onwers can restore clinic
- +6 ;IHS/OIT/LJF 06/28/2006 PATCH 1006 if clinic pattern was deleted by a future inactivation, cannot restore
- +7 ;
- +8 ;D DT^DICRW S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") Q:"^"[X G:Y<0 SDUNC Q:'$D(^SC(+Y,"SL")) ;IHS/ANMC/LJF 8/18/2000
- +9 ;IHS/ANMC/LJF 8/18/2000
- DO DT^DICRW
- SET DIC=44
- SET DIC(0)="MEQA"
- SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))"
- SET DIC("A")="Select CLINIC NAME: "
- SET DIC("W")=$$INACTMSG^BSDU
- DO ^DIC
- KILL DIC("S"),DIC("A")
- IF "^"[X
- QUIT
- IF Y<0
- GOTO SDUNC
- IF '$DATA(^SC(+Y,"SL"))
- QUIT
- +10 ;1/9/2003 WAR per P46,LJF37
- +11 ;IHS/ANMC/LJF 12/18/2002
- IF '$$OWNER^BSDU(+Y,+$GET(DUZ))
- DO MSG^BDGF("You are NOT an owner of this clinic. Please select again.",2,1)
- GOTO SDUNC
- +12 ;IHS/ANMC/LJF 12/18/2002 restoring naked reference
- IF $DATA(^SC(+Y,0))
- +13 ;NAKED REFERENCE - ^SC(IFN,"SL")
- SET SC=+Y
- SET SL=^("SL")
- +14 NEW SDRES
- SET SDRES=$$CLNCK^SDUTL2(SC,1)
- +15 IF 'SDRES
- WRITE !,?5,"Clinic MUST be corrected before continuing."
- GOTO SDUNC
- +16 SET %DT="AEXF"
- SET %DT("A")="RESTORE '"_$PIECE(Y,U,2)_"' FOR WHAT DATE: "
- DO ^%DT
- KILL %DT
- IF Y<0
- QUIT
- +17 SET (SD,CDATE)=Y
- SET %=$PIECE(SL,U,6)
- SET SI=$SELECT(%="":4,%<3:4,%:%,1:4)
- SET %=$PIECE(SL,U,3)
- SET STARTDAY=$SELECT(%:%,1:8)
- +18 KILL SDIN,SDIN1,SDRE,SDRE1
- IF $DATA(^SC(SC,"I"))
- SET SDIN=+^("I")
- SET SDRE=+$PIECE(^("I"),"^",2)
- SET Y=SDIN
- DO DTS^SDUTL
- SET SDIN1=Y
- SET Y=SDRE
- DO DTS^SDUTL
- SET SDRE1=Y
- +19 IF $SELECT('$DATA(SDIN):0,'SDIN:0,SDIN>CDATE:0,SDRE'>CDATE&(SDRE):0,1:1)
- WRITE !,*7,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),SDIN1,$SELECT(SDRE:" to "_SDRE1,1:"")
- GOTO SDUNC
- +20 KILL SDIN,SDIN1,SDRE,SDRE1
- IF '$DATA(^SC(SC,"ST",SD,1))
- GOTO NOWAY
- +21 IF $DATA(^SC(SC,"ST",SD,1))
- IF ^(1)'["CANCELLED"&(^(1)'["X")
- GOTO NOWAY
- +22 IF $DATA(^SC(SC,"ST",SD,9))
- IF $DATA(^SC(SC,"OST",SD,1))
- DO FIX
- IF ^SC(SC,"ST",SD,1)["X"&('$DATA(SDFR1))
- QUIT
- SET ^SC(SC,"ST",SD,1)=HOLD
- IF ^(1)'["X"
- KILL ^SC(SC,"ST",SD,"CAN")
- WRITE !,"RESTORED!",*7
- DO CHK
- QUIT
- +23 IF $DATA(^SC(SC,"ST",SD,9))
- IF '$DATA(^SC(SC,"OST",SD,1))
- GOTO ERRM^SDUNC1
- +24 ;
- +25 ;IHS/OIT/LJF 06/28/2006 PATCH 1006
- +26 ;D B Q:^SC(SC,"ST",SD,1)["X"&('$D(SDFR1)) S ^SC(SC,"ST",SD,0)=SD,^SC(SC,"ST",SD,1)=DH G N
- +27 DO B
- IF ^SC(SC,"ST",SD,1)["X"&('$DATA(SDFR1))
- QUIT
- +28 ;new code
- IF '$DATA(DH)
- WRITE !!,"**** This date CANNOT be RESTORED. ****",!,"Clinic has been INACTIVATED and default slots have been removed.",!,"You must enter the AVAILABILITY again under Set Up A Clinic."
- QUIT
- +29 SET ^SC(SC,"ST",SD,0)=SD
- SET ^SC(SC,"ST",SD,1)=DH
- GOTO N
- +30 ;IHS/OIT/LJF 06/28/2006 end of PATCH 1006 changes
- +31 ;
- +32 IF ^SC(SC,"ST",SD,1)["X"&('$DATA(SDFR1))
- QUIT
- SET ^SC(SC,"ST",SD,0)=SD
- SET ^SC(SC,"ST",SD,1)=DH
- GOTO N
- NOWAY WRITE !,*7,"CLINIC HAS NOT BEEN CANCELLED FOR THAT DATE, SO IT CANNOT BE RESTORED",*7
- GOTO SDUNC
- NOPAT WRITE !,*7,"NO UPCOMING OR INDEFINITE APPOINTMENT PATTERN EXISTS FOR DAY OF WEEK,",!,"CREATE 'AVAILABILITY' PATTERN THRU 'CLINIC SETUP', THEN RESTORE AGAIN",*7
- GOTO SDUNC
- B SET X=SD
- DO DOW^SDM0
- SET DOW=Y
- SET SS=$ORDER(^SC(SC,"T"_Y,X))
- IF SS'=""
- IF $DATA(^(SS,1))
- IF ^(1)]""
- SET DH=$PIECE("SU^MO^TU^WE^TH^FR^SA","^",DOW+1)_" "_$EXTRACT(SD,6,7)_$JUSTIFY("",SI+SI-6)_^(1)
- SET DO=X+1
- SET DA(1)=SC
- SET HOLD=DH
- DO FIX2
- +1 QUIT
- N IF '$FIND(^SC(SC,"ST",SD,1),"[")
- KILL ^SC(SC,"ST",SD)
- WRITE !,*7,"CLINIC DOES NOT MEET ON THAT DAY"
- GOTO SDUNC
- +1 IF ^SC(SC,"ST",SD,1)'["X"
- KILL ^SC(SC,"ST",SD,"CAN")
- WRITE !,"RESTORED!",*7
- DO CHK
- QUIT
- FIX IF ^SC(SC,"ST",SD,1)["X"
- SET SDREST=^SC(SC,"OST",SD,1)
- DO SEL
- QUIT
- +1 SET HOLD=^SC(SC,"OST",SD,1)
- +2 QUIT
- CHK FOR N1=SD:0
- SET N1=$ORDER(^SC(SC,"S",N1))
- IF 'N1!(N1\1-SD)
- QUIT
- IF $DATA(^SC(SC,"S",N1,"MES"))
- DO KMES
- IF $DATA(SDFR1)
- IF '$DATA(^("MES"))
- QUIT
- +1 QUIT
- FIX2 IF ^SC(SC,"ST",SD,1)'["X"
- QUIT
- +1 SET SDREST=DH
- DO SEL
- IF '$DATA(SDFR1)
- QUIT
- SET DH=HOLD
- +2 QUIT
- SEL KILL SDFR1
- IF '$DATA(^SC(SC,"SL"))
- QUIT
- SET SL=^("SL")
- SET %=$PIECE(SL,U,6)
- SET SI=$SELECT(%="":4,%<3:4,%:%,1:4)
- SET %=$PIECE(SL,U,3)
- SET STARTDAY=$SELECT(%:%,1:8)
- +1 WRITE !,"Clinic has been cancelled for the following periods:",!
- +2 ;
- +3 ;IHS/ANMC/LJF 11/30/2000 $N->$O
- +4 ;K SDTEMP,SDZZ S SDZZ=0 F I=SD:0 S I=$N(^SC(SC,"SDCAN",I)) Q:I'>0!(I\1-SD) S SDZZ=SDZZ+1,X=I D TM S SDFR=X,SDFRX=X1,X="."_$P(^(I,0),"^",2) D TM S SDTO=X,SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_SDTO,SDZZ(SDZZ)=SDFRX_"-"_X1
- +5 KILL SDTEMP,SDZZ
- SET SDZZ=0
- FOR I=SD:0
- SET I=$ORDER(^SC(SC,"SDCAN",I))
- IF I'>0!(I\1-SD)
- QUIT
- SET SDZZ=SDZZ+1
- SET X=I
- DO TM
- SET SDFR=X
- SET SDFRX=X1
- SET X="."_$PIECE(^(I,0),"^",2)
- DO TM
- SET SDTO=X
- SET SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_SDTO
- SET SDZZ(SDZZ)=SDFRX_"-"_X1
- +6 ;F I=SD:0 S I=$N(^SC(SC,"S",I)) Q:I'>0!(I\1-SD) I $D(^SC(SC,"S",I,"MES")),'$D(^SC(SC,"SDCAN",I)) S X=I D TM S SDFRX=X1,SDFR=X,X="."_$E(^SC(SC,"S",I,"MES"),17,20) D TM S SDZZ=SDZZ+1,SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_X,SDZZ(SDZZ)=SDFRX_"-"_X1
- +7 FOR I=SD:0
- SET I=$ORDER(^SC(SC,"S",I))
- IF I'>0!(I\1-SD)
- QUIT
- IF $DATA(^SC(SC,"S",I,"MES"))
- IF '$DATA(^SC(SC,"SDCAN",I))
- SET X=I
- DO TM
- SET SDFRX=X1
- SET SDFR=X
- SET X="."_$EXTRACT(^SC(SC,"S",I,"MES"),17,20)
- DO TM
- SET SDZZ=SDZZ+1
- SET SDTEMP(SDFRX_"-"_X1)=SDFR_"^"_X
- SET SDZZ(SDZZ)=SDFRX_"-"_X1
- +8 ;F I1=0:0 S I1=$N(SDZZ(I1)) Q:I1'>0 S I=SDTEMP(SDZZ(I1)) W !,?9,"(",$J(I1,2),") ","From: ",$J($P(I,"^",1),8)," To: ",$J($P(I,"^",2),8)
- +9 FOR I1=0:0
- SET I1=$ORDER(SDZZ(I1))
- IF I1'>0
- QUIT
- SET I=SDTEMP(SDZZ(I1))
- WRITE !,?9,"(",$JUSTIFY(I1,2),") ","From: ",$JUSTIFY($PIECE(I,"^",1),8)," To: ",$JUSTIFY($PIECE(I,"^",2),8)
- +10 ;
- A KILL SDFRX,X1,SDFR,SDTO
- READ !!,"RESTORE WHICH PERIOD?: ",X:DTIME
- IF "^"[X
- QUIT
- +1 IF X?1"?".E
- WRITE !,"Enter the # that precedes the time period you want to restore."
- GOTO A
- +2 SET SDR=X
- IF $DATA(SDZZ(SDR))
- IF $DATA(SDTEMP(SDZZ(SDR)))
- WRITE " ",$PIECE(SDTEMP(SDZZ(SDR)),"^",1)," - ",$PIECE(SDTEMP(SDZZ(SDR)),"^",2)
- GOTO ROK
- +3 WRITE !,*7,"INVALID CHOICE, TRY AGAIN"
- GOTO A
- ROK SET X=$PIECE(SDZZ(SDR),"-",1)
- DO TC
- SET FR=X
- SET SDBEG=%+SI+SI
- SET X=$PIECE(SDZZ(SDR),"-",2)
- DO TC
- SET TO=X
- SET SDEND=%+SI+SI
- +1 SET SDFR1=CDATE+(FR/10000)
- KILL SDTEMP,SDZZ,SDR
- +2 ;S HOLD=^SC(SC,"ST",SD,1),HOLD=$E(HOLD,1,SDBEG-1)_$E(SDREST,SDBEG,SDEND)_$E(HOLD,SDEND+1,80) K ^SC(SC,"SDCAN",SDFR1) I $D(^SC(SC,"SDCAN",0)) S CNT=$P(^(0),U,4),CNT=$S(CNT>0:CNT-1,1:0),^(0)=$P(^(0),U,1,3)_U_CNT K CNT ;IHS/ANMC/LJF 12/13/2000
- +3 ;IHS/ANMC/LJF 12/13/2000
- SET HOLD=^SC(SC,"ST",SD,1)
- SET HOLD=$EXTRACT(HOLD,1,SDBEG-1)_$EXTRACT(SDREST,SDBEG,SDEND)_$EXTRACT(HOLD,SDEND+1,132)
- KILL ^SC(SC,"SDCAN",SDFR1)
- IF $DATA(^SC(SC,"SDCAN",0))
- SET CNT=$PIECE(^(0),U,4)
- SET CNT=$SELECT(CNT>0:CNT-1,1:0)
- SET ^(0)=$PIECE(^(0),U,1,3)_U_CNT
- KILL CNT
- +4 IF HOLD'["["
- SET I5=$FIND(HOLD,"|")
- SET HOLD=$EXTRACT(HOLD,1,(I5-2))_"["_$EXTRACT(HOLD,I5,999)
- KILL I5
- +5 KILL SDBEG,SDEND,SDANS,SI,STARTDAY,FR,TO
- QUIT
- KMES ;NAKED REFERENCE - ^SC(IFN,"S",DATE,"MES")
- IF '$DATA(SDFR1)
- KILL ^("MES")
- QUIT
- +1 ;NAKED REFERENCE - ^SC(IFN,"S",DATE,"MES")
- IF $DATA(SDFR1)
- IF N1=SDFR1
- KILL ^("MES")
- QUIT
- +2 QUIT
- TC SET %=$EXTRACT(X,3,4)
- SET %=X\100-STARTDAY*SI+(%*SI\60)*2
- +1 QUIT
- TM SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
- SET X1=X
- SET %=X>1159
- IF X>1259
- SET X=X-1200
- SET X=X\100_":"_$EXTRACT(X#100+100,2,3)_" "_$EXTRACT("AP",%+1)_"M"
- QUIT
