- SDCNP1A ;ALB/LDB - CANCEL APPT. (continued) ;5/26/05 10:59am
- ;;5.3;Scheduling;**167,340,398,478,517,650**;Aug 13, 1993;Build 3
- ;
- LOOP S SDCNT1=0 F SDAP=0:0 S SDAP=$O(^UTILITY($J,"SDCNP2","REBK",DFN,SDAP)) Q:SDAP'>0 S SDP1=^(SDAP),S1=$P(SDP1,"^",2),S9=$P(^SC(S1,0),"^") D SDDT Q:X8="^" D RBK S MAX=1
- Q
- SDDT W !!,"IN ",S9 D:'$D(DT) DT^SDUTL D DT S %DT="AEX",%DT("A")="START REBOOKING FROM WHAT DATE: "_D S %DT(0)=DT D ^%DT K %DT S X8=X Q:$D(DTOUT)!(X="^") S:X8="" Y=DT G:Y<0 SDDT S SDDT=+Y\1 K X,Y,DIC S X1=SDDT,X2=DT D ^%DTC
- S (M8,MAX)=0,S1=$P(SDP1,"^",2),S2=$P(SDP1,"^"),M1=$S($D(^SC(S1,"SDP")):$P(^("SDP"),"^",4),1:0) D MAX G:M8 SDDT
- I S2>DT S X1=SDDT,X2=1 D C^%DTC S SDDT=X
- Q
- MAX I X>M1 S M8=1 W !!,"Exceeds maximum number of days for rebooking in ",S9 S MAX=0
- Q
- RBK S GDATE=S2,SC=S1,LEN=$P(SDP1,"^",6),A=DFN_"^"_LEN,(CDATE,DATE)=SDDT D OVR1,SDIN D ^SDAUT1 D:'MAX NRBK D:MAX ^SDAUT2,SDNP K SDIN Q
- OVR1 N X S SL=$S($D(^SC(SC,"SL")):^("SL"),1:"") Q:'SL S X=$P(SL,U,6),SI=$S(X="":4,X<3:4,X:X,1:4),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SDSTRTDT=$S(DT>DATE:DT,1:DATE),STIME=$S($D(^SC(SC,"SDP")):$P(^("SDP"),U,3),1:"0800"),SDSTRTDT=SDSTRTDT+2
- Q
- SDIN I $D(^SC(SC,"I")) S SDIN=+^("I") Q
- Q
- SDNP S SDCL(SDAP)=SC_"^"_GDATE_"^"_NDATE S:NDATE SDCNT1=SDCNT1+1 Q
- NRBK W !,"NO REBOOKING ALLOWED FOR ",$P(^SC(SC,0),"^") Q
- DT S X1=$P(DT,"."),X2=10 D C^%DTC S Y=X D D^DIQ S D=Y_"//" Q
- PROT S SDPRT=0 I $D(^SC(+I,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(+I,"SDPRIV",DUZ)) W !,*7,"Appt. in ",$P(^SC(+I,0),"^")," NOT CANCELLED ",!,"Access to this clinic is restricted to only privileged users!",*7 S SDPRT=1 Q
- Q
- ;SD/517 added new IF statement, changed For loop & added 2 new linetags
- FLEN S (ZPL,SDSP)="" ;SD/517
- S COV=$S($P(^DPT(DFN,"S",NDT,0),"^",11)=1:" (COLLATERAL) ",1:"") I $D(^SC(SC,"S",NDT)) S ZL=0 F S ZL=$O(^SC(SC,"S",NDT,1,ZL)) Q:'ZL D
- .I '$D(^SC(SC,"S",NDT,1,ZL,0)) D FLEN1 Q
- .I +^SC(SC,"S",NDT,1,ZL,0)=DFN S APL=$P(^(0),U,2),SDSP=$P($G(^SC(SC,"S",NDT,1,ZL,"CONS")),U)
- .Q
- ;S COV=$S($P(^DPT(DFN,"S",NDT,0),"^",11)=1:" (COLLATERAL) ",1:"") I $D(^SC(SC,"S",NDT)) F ZL=0:0 S ZL=$O(^SC(SC,"S",NDT,1,ZL)) Q:ZL'>0 I +^(ZL,0)=DFN S APL=$P(^(0),"^",2),SDSP=$P($G(^SC(SC,"S",NDT,1,ZL,"CONS")),U) Q ;SD/478
- Q
- ;
- ;SD/517 added new linetag to kill any lingering "C" nodes
- FLEN1 Q:'$D(^SC(SC,"S",NDT,1,ZL,"C"))
- S DA(2)=SC,DA(1)=NDT,DA=ZL,DIK="^SC("_DA(2)_",""S"","_DA(1)_",1," D ^DIK
- Q
- ;
- LOOP1 S SDCNT1=0 F L=0:0 S L=$O(^UTILITY($J,"SDCNP",L)) Q:L'>0 I ^(L)["JUST CANCELLED" S $P(SDCL(L),"^")=$P(^(L),"^",2),$P(SDCL(L),"^",2)=$P(^(L),"^")
- K ^UTILITY($J) Q
- SDLET N NDT,GDT
- U IO D Q
- F SDP=0:0 S SDP=$O(SDCL(SDP)) Q:SDP'>0 D
- . S SDP1=SDCL(SDP),SDC=+SDP1,GDT=$P(SDP1,"^",2),NDT=$P(SDP1,"^",3),SDV1=$P(^SC(SDC,0),"^",15)
- . D B I (SDB)!(SDK) Q
- . S:'SDV1 SDV1=+$O(^DG(40.8,0))
- . D F S:SDLET ^UTILITY($J,SDLET,+A,GDT)=SDC_"^"_NDT
- ;Remove extra page SD*650
- F SDLET=0:0 S SDLET=$O(^UTILITY($J,SDLET)) Q:SDLET'>0 F B0=0:0 S A1=B0,B0=$O(^UTILITY($J,SDLET,B0)) D:'B0 R Q:'B0 D:A1&(A1'=B0) R S A=B0 N SDFIRST S SDFIRST=1 D ^SDLT,APP
- I $D(^UTILITY($J,"NO")) W @IOF,! F SC=0:0 S SC=$O(^UTILITY($J,"NO",SC)) Q:SC'>0 W !,$P(^SC(SC,0),"^")," Clinic is not assigned a letter",!!
- E I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD") I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K ^DIR(0)
- ;I $G(SDB),SDB W !!,"BAD ADDRESS INDICATOR FOR THIS PATIENT. NO LETTER WILL BE PRINTED." S DIR(0)="E" D ^DIR K DIR(0)
- I $G(SDK),'SDK W !!,"NO LETTER CAN BE PRINTED FOR THIS PATIENT." S DIR(0)="E" D ^DIR K DIR(0)
- K A,SDCL D CLOSE^DGUTQ
- Q K A1,SDFORM,SDLET,SDNDT,SDP1,SDV1,^UTILITY($J),SDB,SDK Q
- F S SDFORM="" I $D(^DG(40.8,SDV1,"LTR")),^("LTR") S SDFORM=^("LTR")
- S SDLET="" I $D(^SC(SDC,"LTR")) S:SDWH["P" SDLET=$P(^("LTR"),"^",4) S:SDWH'["P" SDLET=$P(^("LTR"),"^",3)
- I 'SDLET S ^UTILITY($J,"NO",SDC)=""
- Q
- R I $D(^UTILITY($J,"R",SDLET,A1)) W !!,"The appointment(s) have been rescheduled as follows:",! F A2=0:0 S A2=$O(^UTILITY($J,"R",SDLET,A1,A2)) Q:A2'>0 S (X,SDX)=A2,SDC=+^(A2),A=A1,SDS=^DPT(DFN,"S",SDX,0) D WRAPP^SDLT K X,SDX
- D REST^SDLT Q
- APP F SDX=0:0 S SDX=$O(^UTILITY($J,SDLET,A,SDX)) Q:SDX'>0 S S=^DPT(+A,"S",SDX,0),SDC=+^(0) D WRAPP^SDLT I $P(^UTILITY($J,SDLET,A,SDX),"^",2) S ^UTILITY($J,"R",SDLET,A,$P(^UTILITY($J,SDLET,A,SDX),"^",2))=$P(^(SDX),"^")
- Q
- CKK I $L(SDDI)>4!($L(SDDM)>4) S SDERR=1 W !,"There is no appointment number ",$S($L(SDDI)>5:SDDI,1:SDDM) Q
- Q
- CKK1 F Z0=SDDI,SDDM Q:'SDDI!('SDDM&(SDDI-Z0)) S SDERR=0 S:$L(Z0)>5 SDERR=1 Q:SDERR S:$L(SDDI)<5 SDDI=+SDDI S:$L(SDDM)<5 SDDM=+SDDM I $L(Z0)>5!('$D(^UTILITY($J,"SDCNP",Z0,"CNT"))) S SDERR=1 Q
- W:SDERR !,*7,"There is no appointment number ",Z0 H 2 Q
- CKK2 F Z0=SDDI,SDDM Q:'SDDI!('SDDM&(SDDI-Z0)) S SDERR=0 S:$L(Z0)>5 SDERR=1 Q:SDERR S:$L(SDDI)<5 SDDI=+SDDI S:$L(SDDM)<5 SDDM=+SDDM I $L(Z0)>5!('$D(^UTILITY($J,"SDCNP2",DFN,Z0))) S SDERR=1 Q
- W:SDERR !,*7,"There is no appointment number ",Z0 Q
- B S SDB=$$BADADR^DGUTL3(+A)
- S:SDB ^TMP($J,"BADADD",$P(^DPT(+A,0),"^"),+A)=""
- CHECK S SDK=0 I $S('$D(^DPT(+A,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(+A,"S",GDT,0)),$S($P(^(0),"^",2)["N":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(+A,.1)) S SDK=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCNP1A 5232 printed Feb 19, 2025@00:15:39 Page 2
- SDCNP1A ;ALB/LDB - CANCEL APPT. (continued) ;5/26/05 10:59am
- +1 ;;5.3;Scheduling;**167,340,398,478,517,650**;Aug 13, 1993;Build 3
- +2 ;
- LOOP SET SDCNT1=0
- FOR SDAP=0:0
- SET SDAP=$ORDER(^UTILITY($JOB,"SDCNP2","REBK",DFN,SDAP))
- if SDAP'>0
- QUIT
- SET SDP1=^(SDAP)
- SET S1=$PIECE(SDP1,"^",2)
- SET S9=$PIECE(^SC(S1,0),"^")
- DO SDDT
- if X8="^"
- QUIT
- DO RBK
- SET MAX=1
- +1 QUIT
- SDDT WRITE !!,"IN ",S9
- if '$DATA(DT)
- DO DT^SDUTL
- DO DT
- SET %DT="AEX"
- SET %DT("A")="START REBOOKING FROM WHAT DATE: "_D
- SET %DT(0)=DT
- DO ^%DT
- KILL %DT
- SET X8=X
- if $DATA(DTOUT)!(X="^")
- QUIT
- if X8=""
- SET Y=DT
- if Y<0
- GOTO SDDT
- SET SDDT=+Y\1
- KILL X,Y,DIC
- SET X1=SDDT
- SET X2=DT
- DO ^%DTC
- +1 SET (M8,MAX)=0
- SET S1=$PIECE(SDP1,"^",2)
- SET S2=$PIECE(SDP1,"^")
- SET M1=$SELECT($DATA(^SC(S1,"SDP")):$PIECE(^("SDP"),"^",4),1:0)
- DO MAX
- if M8
- GOTO SDDT
- +2 IF S2>DT
- SET X1=SDDT
- SET X2=1
- DO C^%DTC
- SET SDDT=X
- +3 QUIT
- MAX IF X>M1
- SET M8=1
- WRITE !!,"Exceeds maximum number of days for rebooking in ",S9
- SET MAX=0
- +1 QUIT
- RBK SET GDATE=S2
- SET SC=S1
- SET LEN=$PIECE(SDP1,"^",6)
- SET A=DFN_"^"_LEN
- SET (CDATE,DATE)=SDDT
- DO OVR1
- DO SDIN
- DO ^SDAUT1
- if 'MAX
- DO NRBK
- if MAX
- DO ^SDAUT2
- DO SDNP
- KILL SDIN
- QUIT
- OVR1 NEW X
- SET SL=$SELECT($DATA(^SC(SC,"SL")):^("SL"),1:"")
- if 'SL
- QUIT
- SET X=$PIECE(SL,U,6)
- SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
- SET X=$PIECE(SL,U,3)
- SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
- SET SDSTRTDT=$SELECT(DT>DATE:DT,1:DATE)
- SET STIME=$SELECT($DATA(^SC(SC,"SDP")):$PIECE(^("SDP"),U,3),1:"0800")
- SET SDSTRTDT=SDSTRTDT+2
- +1 QUIT
- SDIN IF $DATA(^SC(SC,"I"))
- SET SDIN=+^("I")
- QUIT
- +1 QUIT
- SDNP SET SDCL(SDAP)=SC_"^"_GDATE_"^"_NDATE
- if NDATE
- SET SDCNT1=SDCNT1+1
- QUIT
- NRBK WRITE !,"NO REBOOKING ALLOWED FOR ",$PIECE(^SC(SC,0),"^")
- QUIT
- DT SET X1=$PIECE(DT,".")
- SET X2=10
- DO C^%DTC
- SET Y=X
- DO D^DIQ
- SET D=Y_"//"
- QUIT
- PROT SET SDPRT=0
- IF $DATA(^SC(+I,"SDPROT"))
- IF $PIECE(^("SDPROT"),U)="Y"
- IF '$DATA(^SC(+I,"SDPRIV",DUZ))
- WRITE !,*7,"Appt. in ",$PIECE(^SC(+I,0),"^")," NOT CANCELLED ",!,"Access to this clinic is restricted to only privileged users!",*7
- SET SDPRT=1
- QUIT
- +1 QUIT
- +2 ;SD/517 added new IF statement, changed For loop & added 2 new linetags
- FLEN ;SD/517
- SET (ZPL,SDSP)=""
- +1 SET COV=$SELECT($PIECE(^DPT(DFN,"S",NDT,0),"^",11)=1:" (COLLATERAL) ",1:"")
- IF $DATA(^SC(SC,"S",NDT))
- SET ZL=0
- FOR
- SET ZL=$ORDER(^SC(SC,"S",NDT,1,ZL))
- if 'ZL
- QUIT
- Begin DoDot:1
- +2 IF '$DATA(^SC(SC,"S",NDT,1,ZL,0))
- DO FLEN1
- QUIT
- +3 IF +^SC(SC,"S",NDT,1,ZL,0)=DFN
- SET APL=$PIECE(^(0),U,2)
- SET SDSP=$PIECE($GET(^SC(SC,"S",NDT,1,ZL,"CONS")),U)
- +4 QUIT
- End DoDot:1
- +5 ;S COV=$S($P(^DPT(DFN,"S",NDT,0),"^",11)=1:" (COLLATERAL) ",1:"") I $D(^SC(SC,"S",NDT)) F ZL=0:0 S ZL=$O(^SC(SC,"S",NDT,1,ZL)) Q:ZL'>0 I +^(ZL,0)=DFN S APL=$P(^(0),"^",2),SDSP=$P($G(^SC(SC,"S",NDT,1,ZL,"CONS")),U) Q ;SD/478
- +6 QUIT
- +7 ;
- +8 ;SD/517 added new linetag to kill any lingering "C" nodes
- FLEN1 if '$DATA(^SC(SC,"S",NDT,1,ZL,"C"))
- QUIT
- +1 SET DA(2)=SC
- SET DA(1)=NDT
- SET DA=ZL
- SET DIK="^SC("_DA(2)_",""S"","_DA(1)_",1,"
- DO ^DIK
- +2 QUIT
- +3 ;
- LOOP1 SET SDCNT1=0
- FOR L=0:0
- SET L=$ORDER(^UTILITY($JOB,"SDCNP",L))
- if L'>0
- QUIT
- IF ^(L)["JUST CANCELLED"
- SET $PIECE(SDCL(L),"^")=$PIECE(^(L),"^",2)
- SET $PIECE(SDCL(L),"^",2)=$PIECE(^(L),"^")
- +1 KILL ^UTILITY($JOB)
- QUIT
- SDLET NEW NDT,GDT
- +1 USE IO
- DO Q
- +2 FOR SDP=0:0
- SET SDP=$ORDER(SDCL(SDP))
- if SDP'>0
- QUIT
- Begin DoDot:1
- +3 SET SDP1=SDCL(SDP)
- SET SDC=+SDP1
- SET GDT=$PIECE(SDP1,"^",2)
- SET NDT=$PIECE(SDP1,"^",3)
- SET SDV1=$PIECE(^SC(SDC,0),"^",15)
- +4 DO B
- IF (SDB)!(SDK)
- QUIT
- +5 if 'SDV1
- SET SDV1=+$ORDER(^DG(40.8,0))
- +6 DO F
- if SDLET
- SET ^UTILITY($JOB,SDLET,+A,GDT)=SDC_"^"_NDT
- End DoDot:1
- +7 ;Remove extra page SD*650
- +8 FOR SDLET=0:0
- SET SDLET=$ORDER(^UTILITY($JOB,SDLET))
- if SDLET'>0
- QUIT
- FOR B0=0:0
- SET A1=B0
- SET B0=$ORDER(^UTILITY($JOB,SDLET,B0))
- if 'B0
- DO R
- if 'B0
- QUIT
- if A1&(A1'=B0)
- DO R
- SET A=B0
- NEW SDFIRST
- SET SDFIRST=1
- DO ^SDLT
- DO APP
- +9 IF $DATA(^UTILITY($JOB,"NO"))
- WRITE @IOF,!
- FOR SC=0:0
- SET SC=$ORDER(^UTILITY($JOB,"NO",SC))
- if SC'>0
- QUIT
- WRITE !,$PIECE(^SC(SC,0),"^")," Clinic is not assigned a letter",!!
- E IF $DATA(^TMP($JOB,"BADADD"))
- DO BADADD^SDLT
- KILL ^TMP($JOB,"BADADD")
- IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL ^DIR(0)
- +1 ;I $G(SDB),SDB W !!,"BAD ADDRESS INDICATOR FOR THIS PATIENT. NO LETTER WILL BE PRINTED." S DIR(0)="E" D ^DIR K DIR(0)
- +2 IF $GET(SDK)
- IF 'SDK
- WRITE !!,"NO LETTER CAN BE PRINTED FOR THIS PATIENT."
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR(0)
- +3 KILL A,SDCL
- DO CLOSE^DGUTQ
- Q KILL A1,SDFORM,SDLET,SDNDT,SDP1,SDV1,^UTILITY($JOB),SDB,SDK
- QUIT
- F SET SDFORM=""
- IF $DATA(^DG(40.8,SDV1,"LTR"))
- IF ^("LTR")
- SET SDFORM=^("LTR")
- +1 SET SDLET=""
- IF $DATA(^SC(SDC,"LTR"))
- if SDWH["P"
- SET SDLET=$PIECE(^("LTR"),"^",4)
- if SDWH'["P"
- SET SDLET=$PIECE(^("LTR"),"^",3)
- +2 IF 'SDLET
- SET ^UTILITY($JOB,"NO",SDC)=""
- +3 QUIT
- R IF $DATA(^UTILITY($JOB,"R",SDLET,A1))
- WRITE !!,"The appointment(s) have been rescheduled as follows:",!
- FOR A2=0:0
- SET A2=$ORDER(^UTILITY($JOB,"R",SDLET,A1,A2))
- if A2'>0
- QUIT
- SET (X,SDX)=A2
- SET SDC=+^(A2)
- SET A=A1
- SET SDS=^DPT(DFN,"S",SDX,0)
- DO WRAPP^SDLT
- KILL X,SDX
- +1 DO REST^SDLT
- QUIT
- APP FOR SDX=0:0
- SET SDX=$ORDER(^UTILITY($JOB,SDLET,A,SDX))
- if SDX'>0
- QUIT
- SET S=^DPT(+A,"S",SDX,0)
- SET SDC=+^(0)
- DO WRAPP^SDLT
- IF $PIECE(^UTILITY($JOB,SDLET,A,SDX),"^",2)
- SET ^UTILITY($JOB,"R",SDLET,A,$PIECE(^UTILITY($JOB,SDLET,A,SDX),"^",2))=$PIECE(^(SDX),"^")
- +1 QUIT
- CKK IF $LENGTH(SDDI)>4!($LENGTH(SDDM)>4)
- SET SDERR=1
- WRITE !,"There is no appointment number ",$SELECT($LENGTH(SDDI)>5:SDDI,1:SDDM)
- QUIT
- +1 QUIT
- CKK1 FOR Z0=SDDI,SDDM
- if 'SDDI!('SDDM&(SDDI-Z0))
- QUIT
- SET SDERR=0
- if $LENGTH(Z0)>5
- SET SDERR=1
- if SDERR
- QUIT
- if $LENGTH(SDDI)<5
- SET SDDI=+SDDI
- if $LENGTH(SDDM)<5
- SET SDDM=+SDDM
- IF $LENGTH(Z0)>5!('$DATA(^UTILITY($JOB,"SDCNP",Z0,"CNT")))
- SET SDERR=1
- QUIT
- +1 if SDERR
- WRITE !,*7,"There is no appointment number ",Z0
- HANG 2
- QUIT
- CKK2 FOR Z0=SDDI,SDDM
- if 'SDDI!('SDDM&(SDDI-Z0))
- QUIT
- SET SDERR=0
- if $LENGTH(Z0)>5
- SET SDERR=1
- if SDERR
- QUIT
- if $LENGTH(SDDI)<5
- SET SDDI=+SDDI
- if $LENGTH(SDDM)<5
- SET SDDM=+SDDM
- IF $LENGTH(Z0)>5!('$DATA(^UTILITY($JOB,"SDCNP2",DFN,Z0)))
- SET SDERR=1
- QUIT
- +1 if SDERR
- WRITE !,*7,"There is no appointment number ",Z0
- QUIT
- B SET SDB=$$BADADR^DGUTL3(+A)
- +1 if SDB
- SET ^TMP($JOB,"BADADD",$PIECE(^DPT(+A,0),"^"),+A)=""
- CHECK SET SDK=0
- IF $SELECT('$DATA(^DPT(+A,.35)):1,$PIECE(^(.35),"^",1)']"":1,1:0)
- IF $DATA(^DPT(+A,"S",GDT,0))
- IF $SELECT($PIECE(^(0),"^",2)["N":1,$DATA(SDCP)&$PIECE(^(0),"^",2)["C":1,1:0)
- IF $PIECE(^(0),"^",14)=SDTIME!(SDTIME="*")
- IF '$DATA(^DPT(+A,.1))
- SET SDK=1
- +1 QUIT
