- SDM2 ;SF/GFT - MAKE APPOINTMENT ; 07 Jan 2000 6:30 PM
- ;;5.3;Scheduling;**32,132,168,356,434,467,478,671**;Aug 13, 1993;Build 25
- ;
- ;SD/467 - call EWL to open its entry if matching appointment is canceled
- W *7,!,"PATIENT ALREADY HAS APPOINTMENT "
- N SDATA,SDCMHDL ; for evt dvr
- ;Patch SD*5.3*671 take away prompt to cancel appointment when patient has a appointment in same clinic added ';' before Read
- I $D(^DPT(DFN,"S",SD,0)),$P(^(0),"^",2)'["C" S S=SD,I=+^(0) D FLEN W "(",APL," MINUTES) THEN" D IN W !,"CANCEL THAT APPOINTMENT OR SELECT A NEW DATE/TIME." Q
- ;,PROT G:$D(SDPROT) ^SDM1 R ".",!," DO YOU WANT TO CANCEL IT? ",X:DTIME S X=$$UP^XLFSTR(X) D:X?1"Y".A STAT G CAN:X?1"Y".A W "??",*7 G ^SDM1
- SDAY S %=2 W "ON THE SAME DAY (" D AT,IN W ") ...OK" D YN^DICN I '% W !,"RESPOND YES OR NO",!,"PATIENT ALREADY HAS APPOINTMENT " G SDAY
- G ^SDM1:(%-1),PRECAN^SDM1
- ;
- CAN Q:'$D(^SC(I,"SL")) S SCI=I,DIV=$S($P(^SC(I,0),"^",15)]"":" "_$P(^(0),"^",15),1:" 1") I $D(^DPT("ASDPSD","C",DIV,I,S,DFN)) K ^(DFN)
- S SD17=$P(^DPT(DFN,"S",S,0),"^") K ^SC("ARAD",I,S,DFN) S (DA,SDSY)=0 F SDSX=0:0 S SDSX=$O(^SC(I,"S",S,1,SDSX)) Q:'SDSX Q:'$D(^(SDSX,0)) D C Q:SDSY&(DA)
- I $D(^DPT("ASDPSD","B",DIV,$P(S,"."),DFN)) D CK1
- G OUT:'SDSY S SL1=$P(^SC(I,"S",S,1,SDSY,0),U,2) I DA,'$D(^("OB")) K ^SC(I,"S",S,1,DA,"OB")
- S SDRT="D",SDTTM=SD,SDPL=SDSY,SDSC=I D RT^SDUTL
- I I'=SC D
- .W !
- .I $$BADADR^DGUTL3(DFN)>0 D Q
- ..W !!,"**BAD ADDRESS INDICATOR FOR THIS PATIENT. NO LETTER WILL BE PRINTED.**",!!
- .S DIR("A")="DO YOU WISH TO PRINT LETTERS FOR THE CANCELLED APPOINTMENT"
- .S DIR("A",1)="THIS IS THE ONLY OPPORTUNITY.",DIR("B")="YES"
- .S DIR(0)="Y" D ^DIR W ! K DIR
- .Q:(Y'=1)
- .N SDWH,A,SC,SDCL S SDWH="P",A=+DFN,SDCL(1)=I_"^"_S N DFN
- .S %ZIS("A")="Device for cancellation letter: ",%ZIS("B")=""
- .N I,S,SDHX,SDP
- .D ^%ZIS Q:POP U IO
- .D SDLET^SDCNP1A
- .D ^%ZISC
- N SCSNOD,SCLNK,SCSRV,SCGMR,SCSTPCOD
- S SCSNOD=^SC(I,"S",S,1,SDSY,0),SCLNK=$P($G(^SC(I,"S",S,1,SDSY,"CONS")),U),SDADM="" S:'$D(STPCOD) STPCOD=$P($G(^SC(I,0)),U,7) K TMPD ;SD/478
- I SCLNK'="" K ^SC("AWAS1",SCLNK) S SCSRV=$P($G(^GMR(123,SCLNK,0)),U,5),SCGMR=0 F S SCGMR=$O(^GMR(123.5,SCSRV,688,SCGMR)) Q:'+SCGMR S SCSTPCOD=$P(^GMR(123.5,SCSRV,688,SCGMR,0),U) I STPCOD=SCSTPCOD D
- .S TMP=1 S:'$D(CNSLTLNK) CNSLTLNK=SCLNK Q ;SD/478
- K ^SC(I,"S",S,1,SDSY)
- I '$D(^SC(I,"ST",$P(SD,"."),1)) G OUT
- S SD1(1)=^SC(I,"SL"),SD1=$P(SD1(1),"^",3),SB1=$S(SD1:SD1,1:8)-1/100,SD1=$P(SD1(1),"^",6),HSI1=$S(SD1:SD1,1:4),SI1=$S(SD1="":4,SD1<3:4,SD1:SD1,1:4),SDDIF1=$S(HSI1<3:8/HSI1,1:2) K SD1
- S S=^SC(I,"ST",$P(SD,"."),1),SDQ=SD#1-SB1*100,ST=SDQ#1*SI1\.6+($P(SDQ,".")*SI1),SS=SL1*HSI1/60
- I SDQ'<1 F I=ST+ST:SDDIF1 S SDQ=$E(STR,$F(STR,$E(S,I+1))) Q:SDQ="" S S=$E(S,1,I)_SDQ_$E(S,I+2,999),SS=SS-1 Q:SS'>0
- S ^(1)=S K SL1,SB1,SDDIF1,HSI1,SI1,SDQ ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
- OUT D EVT Q:$D(SDNSF) D CANCEL^SDCNSLT W *7,!,"APPOINTMENT IN ",$P(^SC(SCI,0),"^",1)," CANCELLED!" S X=SD D DOW^SDM1 W !,"APPOINTMENT NOW BEING MADE IN ",$P(^SC(SC,0),"^",1) K SCI G S^SDM1 ;SD/478
- ;
- C I +^SC(I,"S",S,1,SDSX,0)=DFN,$P(^(0),"^",9)'["C" S SDSY=SDSX Q
- Q:'$D(^("OB"))!DA S:^("OB")?1"O".E DA=SDSX Q ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDSX,"OB")
- ;
- AT W "AT ",$E(S_0,9,10),":",$E(S_"000",11,12) Q
- IN W:SC-I&$D(^SC(I,0)) " IN ",$P(^(0),U,1) Q
- PROT K SDPROT
- I $D(^SC(I,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(I,"SDPRIV",DUZ)) D Q
- .W !!,*7,">>> Access to ",$$CNAM(I)," is prohibited!"
- .W !," Only users with a special code may access this clinic.",!
- .S SDPROT=""
- ;
- I $$CODT^SDCOU(DFN,SD,I) D Q
- .W !?5,*7,">>> A check out date has been entered for this appointment!"
- .W !?5," Please enter another date and time. Thank you.",!
- .S SDPROT=""
- Q
- ;
- CNAM(SDCL) ;Return clinic name
- ;Input: SDCL=clinic ien
- N SDX
- S SDX=$P($G(^SC(+SDCL,0)),U)
- Q $S($L(SDX):SDX,1:"this clinic")
- ;
- FLEN S APL="" I $D(^SC(I,"S",SD)) F ZL=0:0 S ZL=$O(^SC(I,"S",SD,1,ZL)) Q:ZL="" I +^(ZL,0)=DFN S APL=$P(^SC(I,"S",SD,1,ZL,0),"^",2)
- Q
- ;
- DISP G ^SDM1 ; LINE TAG IS NO LONGER USED
- ;W !?4 K S F SDQ=Y:0 S SDQ=$N(^SC(SC,"S",SDQ)) Q:Y+1<SDQ!(SDQ<0) F I=0:0 S I=$N(^SC(SC,"S",SDQ,1,I)) Q:I'>0 Q:'$D(^(I,0)) S ST=$S($P(^(0),U,4)="":"BLANK",1:"'"_$E($P(^(0),U,4),1,28)_"'"),S(ST)=$S($D(S(ST)):S(ST)+1,1:1)
- ;I '$D(S) W "NO APPNT'S SCHEDULED YET" G ^SDM1
- ;W "'OTHER' TYPES ALREADY SCHEDULED: ",!
- ;S S=0 F I=0:1 S S=$N(S(S)) G ^SDM1:S=-1 W:$X+$L(S)>72 ! W S,": ",S(S)," "
- CK1 S SDZ=0 F SD1=$P(S,"."):0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(S\1)) I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDZ=1 Q
- Q:SDZ F SD1=2,4 I $D(^SC("AAS",SD1,$P(S,"."),DFN)) S SDZ=1 Q
- Q:SDZ IF $D(^SCE(+$$EXAE^SDOE(DFN,S\1,S\1),0)) S SDX=1
- Q:SDZ K ^DPT("ASDPSD","B",DIV,$P(S,"."),DFN) Q
- STAT N X S SDCMHDL=$$HANDLE^SDAMEVT(1) D BEFORE^SDAMEVT(.SDATA,DFN,SD,I,"",SDCMHDL),NOW^%DTC
- S $P(^DPT(DFN,"S",SD,0),"^",2)="C",$P(^(0),"^",14)=$E(%,1,12) S:$D(DUZ) $P(^(0),"^",12)=DUZ S ^DPT("ASDCN",+^(0),SD,DFN)=""
- K ^TMP("SDWLREB",$J),^TMP($J,"SDWLPL") N SC S SC=+^DPT(DFN,"S",SD,0) D OPENEWL^SDWLREB(DFN,SD,SC,0) K ^TMP($J,"SDWLP")
- I $D(^TMP("SDWLREB",$J)) D MESS^SDWLREB ; SD/467
- Q
- ;
- EVT ; -- separate tag if need to NEW vars
- ; -- cancel event
- D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCMHDL)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDM2 5321 printed Feb 19, 2025@00:25 Page 2
- SDM2 ;SF/GFT - MAKE APPOINTMENT ; 07 Jan 2000 6:30 PM
- +1 ;;5.3;Scheduling;**32,132,168,356,434,467,478,671**;Aug 13, 1993;Build 25
- +2 ;
- +3 ;SD/467 - call EWL to open its entry if matching appointment is canceled
- +4 WRITE *7,!,"PATIENT ALREADY HAS APPOINTMENT "
- +5 ; for evt dvr
- NEW SDATA,SDCMHDL
- +6 ;Patch SD*5.3*671 take away prompt to cancel appointment when patient has a appointment in same clinic added ';' before Read
- +7 IF $DATA(^DPT(DFN,"S",SD,0))
- IF $PIECE(^(0),"^",2)'["C"
- SET S=SD
- SET I=+^(0)
- DO FLEN
- WRITE "(",APL," MINUTES) THEN"
- DO IN
- WRITE !,"CANCEL THAT APPOINTMENT OR SELECT A NEW DATE/TIME."
- QUIT
- +8 ;,PROT G:$D(SDPROT) ^SDM1 R ".",!," DO YOU WANT TO CANCEL IT? ",X:DTIME S X=$$UP^XLFSTR(X) D:X?1"Y".A STAT G CAN:X?1"Y".A W "??",*7 G ^SDM1
- SDAY SET %=2
- WRITE "ON THE SAME DAY ("
- DO AT
- DO IN
- WRITE ") ...OK"
- DO YN^DICN
- IF '%
- WRITE !,"RESPOND YES OR NO",!,"PATIENT ALREADY HAS APPOINTMENT "
- GOTO SDAY
- +1 if (%-1)
- GOTO ^SDM1
- GOTO PRECAN^SDM1
- +2 ;
- CAN if '$DATA(^SC(I,"SL"))
- QUIT
- SET SCI=I
- SET DIV=$SELECT($PIECE(^SC(I,0),"^",15)]"":" "_$PIECE(^(0),"^",15),1:" 1")
- IF $DATA(^DPT("ASDPSD","C",DIV,I,S,DFN))
- KILL ^(DFN)
- +1 SET SD17=$PIECE(^DPT(DFN,"S",S,0),"^")
- KILL ^SC("ARAD",I,S,DFN)
- SET (DA,SDSY)=0
- FOR SDSX=0:0
- SET SDSX=$ORDER(^SC(I,"S",S,1,SDSX))
- if 'SDSX
- QUIT
- if '$DATA(^(SDSX,0))
- QUIT
- DO C
- if SDSY&(DA)
- QUIT
- +2 IF $DATA(^DPT("ASDPSD","B",DIV,$PIECE(S,"."),DFN))
- DO CK1
- +3 if 'SDSY
- GOTO OUT
- SET SL1=$PIECE(^SC(I,"S",S,1,SDSY,0),U,2)
- IF DA
- IF '$DATA(^("OB"))
- KILL ^SC(I,"S",S,1,DA,"OB")
- +4 SET SDRT="D"
- SET SDTTM=SD
- SET SDPL=SDSY
- SET SDSC=I
- DO RT^SDUTL
- +5 IF I'=SC
- Begin DoDot:1
- +6 WRITE !
- +7 IF $$BADADR^DGUTL3(DFN)>0
- Begin DoDot:2
- +8 WRITE !!,"**BAD ADDRESS INDICATOR FOR THIS PATIENT. NO LETTER WILL BE PRINTED.**",!!
- End DoDot:2
- QUIT
- +9 SET DIR("A")="DO YOU WISH TO PRINT LETTERS FOR THE CANCELLED APPOINTMENT"
- +10 SET DIR("A",1)="THIS IS THE ONLY OPPORTUNITY."
- SET DIR("B")="YES"
- +11 SET DIR(0)="Y"
- DO ^DIR
- WRITE !
- KILL DIR
- +12 if (Y'=1)
- QUIT
- +13 NEW SDWH,A,SC,SDCL
- SET SDWH="P"
- SET A=+DFN
- SET SDCL(1)=I_"^"_S
- NEW DFN
- +14 SET %ZIS("A")="Device for cancellation letter: "
- SET %ZIS("B")=""
- +15 NEW I,S,SDHX,SDP
- +16 DO ^%ZIS
- if POP
- QUIT
- USE IO
- +17 DO SDLET^SDCNP1A
- +18 DO ^%ZISC
- End DoDot:1
- +19 NEW SCSNOD,SCLNK,SCSRV,SCGMR,SCSTPCOD
- +20 ;SD/478
- SET SCSNOD=^SC(I,"S",S,1,SDSY,0)
- SET SCLNK=$PIECE($GET(^SC(I,"S",S,1,SDSY,"CONS")),U)
- SET SDADM=""
- if '$DATA(STPCOD)
- SET STPCOD=$PIECE($GET(^SC(I,0)),U,7)
- KILL TMPD
- +21 IF SCLNK'=""
- KILL ^SC("AWAS1",SCLNK)
- SET SCSRV=$PIECE($GET(^GMR(123,SCLNK,0)),U,5)
- SET SCGMR=0
- FOR
- SET SCGMR=$ORDER(^GMR(123.5,SCSRV,688,SCGMR))
- if '+SCGMR
- QUIT
- SET SCSTPCOD=$PIECE(^GMR(123.5,SCSRV,688,SCGMR,0),U)
- IF STPCOD=SCSTPCOD
- Begin DoDot:1
- +22 ;SD/478
- SET TMP=1
- if '$DATA(CNSLTLNK)
- SET CNSLTLNK=SCLNK
- QUIT
- End DoDot:1
- +23 KILL ^SC(I,"S",S,1,SDSY)
- +24 IF '$DATA(^SC(I,"ST",$PIECE(SD,"."),1))
- GOTO OUT
- +25 SET SD1(1)=^SC(I,"SL")
- SET SD1=$PIECE(SD1(1),"^",3)
- SET SB1=$SELECT(SD1:SD1,1:8)-1/100
- SET SD1=$PIECE(SD1(1),"^",6)
- SET HSI1=$SELECT(SD1:SD1,1:4)
- SET SI1=$SELECT(SD1="":4,SD1<3:4,SD1:SD1,1:4)
- SET SDDIF1=$SELECT(HSI1<3:8/HSI1,1:2)
- KILL SD1
- +26 SET S=^SC(I,"ST",$PIECE(SD,"."),1)
- SET SDQ=SD#1-SB1*100
- SET ST=SDQ#1*SI1\.6+($PIECE(SDQ,".")*SI1)
- SET SS=SL1*HSI1/60
- +27 IF SDQ'<1
- FOR I=ST+ST:SDDIF1
- SET SDQ=$EXTRACT(STR,$FIND(STR,$EXTRACT(S,I+1)))
- if SDQ=""
- QUIT
- SET S=$EXTRACT(S,1,I)_SDQ_$EXTRACT(S,I+2,999)
- SET SS=SS-1
- if SS'>0
- QUIT
- +28 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
- SET ^(1)=S
- KILL SL1,SB1,SDDIF1,HSI1,SI1,SDQ
- OUT ;SD/478
- DO EVT
- if $DATA(SDNSF)
- QUIT
- DO CANCEL^SDCNSLT
- WRITE *7,!,"APPOINTMENT IN ",$PIECE(^SC(SCI,0),"^",1)," CANCELLED!"
- SET X=SD
- DO DOW^SDM1
- WRITE !,"APPOINTMENT NOW BEING MADE IN ",$PIECE(^SC(SC,0),"^",1)
- KILL SCI
- GOTO S^SDM1
- +1 ;
- C IF +^SC(I,"S",S,1,SDSX,0)=DFN
- IF $PIECE(^(0),"^",9)'["C"
- SET SDSY=SDSX
- QUIT
- +1 ;NAKED REFERENCE - ^SC(IFN,"S",Date,1,SDSX,"OB")
- if '$DATA(^("OB"))!DA
- QUIT
- if ^("OB")?1"O".E
- SET DA=SDSX
- QUIT
- +2 ;
- AT WRITE "AT ",$EXTRACT(S_0,9,10),":",$EXTRACT(S_"000",11,12)
- QUIT
- IN if SC-I&$DATA(^SC(I,0))
- WRITE " IN ",$PIECE(^(0),U,1)
- QUIT
- PROT KILL SDPROT
- +1 IF $DATA(^SC(I,"SDPROT"))
- IF $PIECE(^("SDPROT"),U)="Y"
- IF '$DATA(^SC(I,"SDPRIV",DUZ))
- Begin DoDot:1
- +2 WRITE !!,*7,">>> Access to ",$$CNAM(I)," is prohibited!"
- +3 WRITE !," Only users with a special code may access this clinic.",!
- +4 SET SDPROT=""
- End DoDot:1
- QUIT
- +5 ;
- +6 IF $$CODT^SDCOU(DFN,SD,I)
- Begin DoDot:1
- +7 WRITE !?5,*7,">>> A check out date has been entered for this appointment!"
- +8 WRITE !?5," Please enter another date and time. Thank you.",!
- +9 SET SDPROT=""
- End DoDot:1
- QUIT
- +10 QUIT
- +11 ;
- CNAM(SDCL) ;Return clinic name
- +1 ;Input: SDCL=clinic ien
- +2 NEW SDX
- +3 SET SDX=$PIECE($GET(^SC(+SDCL,0)),U)
- +4 QUIT $SELECT($LENGTH(SDX):SDX,1:"this clinic")
- +5 ;
- FLEN SET APL=""
- IF $DATA(^SC(I,"S",SD))
- FOR ZL=0:0
- SET ZL=$ORDER(^SC(I,"S",SD,1,ZL))
- if ZL=""
- QUIT
- IF +^(ZL,0)=DFN
- SET APL=$PIECE(^SC(I,"S",SD,1,ZL,0),"^",2)
- +1 QUIT
- +2 ;
- DISP ; LINE TAG IS NO LONGER USED
- GOTO ^SDM1
- +1 ;W !?4 K S F SDQ=Y:0 S SDQ=$N(^SC(SC,"S",SDQ)) Q:Y+1<SDQ!(SDQ<0) F I=0:0 S I=$N(^SC(SC,"S",SDQ,1,I)) Q:I'>0 Q:'$D(^(I,0)) S ST=$S($P(^(0),U,4)="":"BLANK",1:"'"_$E($P(^(0),U,4),1,28)_"'"),S(ST)=$S($D(S(ST)):S(ST)+1,1:1)
- +2 ;I '$D(S) W "NO APPNT'S SCHEDULED YET" G ^SDM1
- +3 ;W "'OTHER' TYPES ALREADY SCHEDULED: ",!
- +4 ;S S=0 F I=0:1 S S=$N(S(S)) G ^SDM1:S=-1 W:$X+$L(S)>72 ! W S,": ",S(S)," "
- CK1 SET SDZ=0
- FOR SD1=$PIECE(S,"."):0
- SET SD1=$ORDER(^DPT(DFN,"S",SD1))
- if 'SD1!((SD1\1)'=(S\1))
- QUIT
- IF $PIECE(^(SD1,0),"^",2)'["C"
- IF $PIECE(^(0),"^",2)'["N"
- SET SDZ=1
- QUIT
- +1 if SDZ
- QUIT
- FOR SD1=2,4
- IF $DATA(^SC("AAS",SD1,$PIECE(S,"."),DFN))
- SET SDZ=1
- QUIT
- +2 if SDZ
- QUIT
- IF $DATA(^SCE(+$$EXAE^SDOE(DFN,S\1,S\1),0))
- SET SDX=1
- +3 if SDZ
- QUIT
- KILL ^DPT("ASDPSD","B",DIV,$PIECE(S,"."),DFN)
- QUIT
- STAT NEW X
- SET SDCMHDL=$$HANDLE^SDAMEVT(1)
- DO BEFORE^SDAMEVT(.SDATA,DFN,SD,I,"",SDCMHDL)
- DO NOW^%DTC
- +1 SET $PIECE(^DPT(DFN,"S",SD,0),"^",2)="C"
- SET $PIECE(^(0),"^",14)=$EXTRACT(%,1,12)
- if $DATA(DUZ)
- SET $PIECE(^(0),"^",12)=DUZ
- SET ^DPT("ASDCN",+^(0),SD,DFN)=""
- +2 KILL ^TMP("SDWLREB",$JOB),^TMP($JOB,"SDWLPL")
- NEW SC
- SET SC=+^DPT(DFN,"S",SD,0)
- DO OPENEWL^SDWLREB(DFN,SD,SC,0)
- KILL ^TMP($JOB,"SDWLP")
- +3 ; SD/467
- IF $DATA(^TMP("SDWLREB",$JOB))
- DO MESS^SDWLREB
- +4 QUIT
- +5 ;
- EVT ; -- separate tag if need to NEW vars
- +1 ; -- cancel event
- +2 DO CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCMHDL)
- +3 QUIT
