SDM2 ;SF/GFT - MAKE APPOINTMENT ; 07 Jan 2000 6:30 PM
;;5.3;Scheduling;**32,132,168,356,434,467,478,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 10/18/2000 added check: user have access to princ clin?
;
;
;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
I $D(^DPT(DFN,"S",SD,0)),$P(^(0),"^",2)'["C" S S=SD,I=+^(0) D FLEN W "(",APL," MINUTES) THEN" D IN,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 %=1 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 ;IHS/ANMC/LJF 10/18/2000
I $D(^SC(I,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(I,"SDPRIV",DUZ)),'$D(^SC($$PC^BSDU(I),"SDPRIV",DUZ)) D Q ;IHS/ANMC/LJF 10/18/2000
.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
SDM2 ;SF/GFT - MAKE APPOINTMENT ; 07 Jan 2000 6:30 PM
+1 ;;5.3;Scheduling;**32,132,168,356,434,467,478,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 10/18/2000 added check: user have access to princ clin?
+3 ;
+4 ;
+5 ;SD/467 - call EWL to open its entry if matching appointment is canceled
+6 WRITE *7,!,"PATIENT ALREADY HAS APPOINTMENT "
+7 ; for evt dvr
NEW SDATA,SDCMHDL
+8 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
DO PROT
IF $DATA(SDPROT)
GOTO ^SDM1
READ ".",!," DO YOU WANT TO CANCEL IT? ",X:DTIME
SET X=$$UP^XLFSTR(X)
IF X?1"Y".A
DO STAT
IF X?1"Y".A
GOTO CAN
WRITE "??",*7
GOTO ^SDM1
SDAY SET %=1
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 ;I $D(^SC(I,"SDPROT")),$P(^("SDPROT"),U)="Y",'$D(^SC(I,"SDPRIV",DUZ)) D Q ;IHS/ANMC/LJF 10/18/2000
+2 ;IHS/ANMC/LJF 10/18/2000
IF $DATA(^SC(I,"SDPROT"))
IF $PIECE(^("SDPROT"),U)="Y"
IF '$DATA(^SC(I,"SDPRIV",DUZ))
IF '$DATA(^SC($$PC^BSDU(I),"SDPRIV",DUZ))
Begin DoDot:1
+3 WRITE !!,*7,">>> Access to ",$$CNAM(I)," is prohibited!"
+4 WRITE !," Only users with a special code may access this clinic.",!
+5 SET SDPROT=""
End DoDot:1
QUIT
+6 ;
+7 IF $$CODT^SDCOU(DFN,SD,I)
Begin DoDot:1
+8 WRITE !?5,*7,">>> A check out date has been entered for this appointment!"
+9 WRITE !?5," Please enter another date and time. Thank you.",!
+10 SET SDPROT=""
End DoDot:1
QUIT
+11 QUIT
+12 ;
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
