- SDCNP0 ;ALB/LDB,ANU,MGD - CANCEL APPT. FOR A PATIENT ;MAY 30, 2024
- ;;5.3;Scheduling;**132,167,478,517,572,592,627,658,801,803,804,884**;Aug 13, 1993;Build 1
- ;;Per VHA Directive 6402, this routine should not be modified
- ; Reference/ICR
- ; ^VALM1 - 10116
- ;
- EN2 D WAIT^DICD S NDT=HDT/1,L=0 F J=1:1 S NDT=$O(^DPT(DFN,"S",NDT)) Q:NDT'>0!(SDPV&(NDT'<SDTM)) S SD0=^(NDT,0) I $P(SD0,"^",2)'["C" S SC=+SD0,L=L\1+1,APL="" D FLEN^SDCNP1A S ^UTILITY($J,"SDCNP",L)=NDT_"^"_SC_"^"_COV_"^"_APL_"^^"_APL D CHKSO
- WH1 G:L'>0 NO S (SDCTRL,SDCTR)=0,APP="" N SDITEM W:'SDERR @IOF
- W ! F Z=0:0 S Z=$O(^UTILITY($J,"SDCNP",Z)) Q:Z'>0 S SDITEM=$J($S(Z\1=Z:"("_$J(Z,2)_") ",1:""),5) D Q:SDCTRL
- .I SDITEM["(" W !,SDITEM S HLDCSND=""
- .I SDITEM'["(" W SDITEM
- .S AT=$S($P(^(Z),"^",2)'?.N:1,1:0),Y=$P($P(^(Z),"^"),".") D DT^SDM0 S X=$P(^(Z),"^"),^(Z,"CNT")="" X ^DD("FUNC",2,1) W " ",$J(X,8) D MORE W:AT ! Q:SDCTRL
- S:SDERR SDCTRL=1 I Z>0 G:SDCTRL&(APP']"") NOPE^SDCNP1 G:SDCTRL DEL
- D WH G NOPE^SDCNP1:APP']"",DEL
- WH W !!,"SELECT APPOINTMENTS TO BE CANCELLED" W:Z>0 " OR HIT RETURN TO CONTINUE DISPLAY" R ": ",APP:DTIME I '$T!(APP="^") S SDCTRL=1,APP="" Q
- S SDMSG="W !,""Enter appt. numbers separated by commas and/or a range separated"",!,""by dashes (ie 2,4,6-9)"" H 2" I APP["?" X SDMSG G WH
- S SDCTRL=$S(APP']"":0,1:1) Q
- DEL S SDERR=0 F J=1:1 S SDDH=$P(APP,",",J) Q:SDDH']"" D MTCH^SDCNP1
- G:SDERR WH1
- DEL1 F J=1:1 S SDDH=$P(APP,",",J) Q:SDDH']"" S SDDI=$P(SDDH,"-"),SDDM=$P(SDDH,"-",2) D CKK^SDCNP1A Q:SDERR D CKK1^SDCNP1A Q:SDERR Q:'SDDI F A1=SDDI:1:$S(SDDM:SDDM,1:SDDI) D BEGD
- G:SDERR WH1 G NOPE^SDCNP1
- BEGD S (SD,S)=$P(^UTILITY($J,"SDCNP",A1),"^",1),I=$P(^UTILITY($J,"SDCNP",A1),"^",2)
- S SL=^SC(I,"SL"),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y
- ; SD*5.3*803 - Check if Check In Date exists and not allow cancel
- I $P($G(^SC(+$P(^UTILITY($J,"SDCNP",A1),U,2),"S",+^UTILITY($J,"SDCNP",A1),1,+$$FIND^SDAM2(.DFN,+^UTILITY($J,"SDCNP",A1),+$P(^(A1),U,2)),"C")),U,1) W !,*7,">>> Appointment #",A1," has a check in date and cannot be cancelled." Q
- I $$CODT^SDCOU(DFN,+^UTILITY($J,"SDCNP",A1),+$P(^(A1),U,2)) W !,*7,">>> Appointment #",A1," has a check out date and cannot be cancelled." Q
- D PROT^SDCNP1A Q:SDPRT=1
- ;
- N SDCANCELVVS,SDVVSAPPT
- S (SDCANCELVVS,SDVVSAPPT)=""
- D CANCELVVS(DFN,A1,SDWH,SDSCR,.SDCANCELVVS,.SDVVSAPPT)
- ;
- D CAN S $P(^UTILITY($J,"SDCNP",A1),"^",4)="*** JUST CANCELLED ***" Q
- CAN Q:$P(^UTILITY($J,"SDCNP",A1),"^",4)["JUST CANCELLED" S CNT=CNT+1,DIV=$S($P(^SC(I,0),"^",15)]"":" "_$P(^(0),"^",15),1:" 1") I $D(^DPT("ASDPSD","C",DIV,I,S,DFN)) K ^(DFN)
- N SDATA,SDCPHDL,SDNOW,SDCLI S SDCPHDL=$$HANDLE^SDAMEVT(1) D BEFORE^SDAMEVT(.SDATA,DFN,S,I,"",SDCPHDL)
- S SDCLI=I ;changed variable name I to SDCLI(Hospital location file IEN) as the value of I is manipulated by ^DIE SD*5.3*592
- S:'$D(^DPT(DFN,"S",0)) ^(0)="^2.98P^^" I $D(SDREM) S DIE="^DPT("_DFN_",""S"",",(DA,Y)=S,DA(1)=DFN,DR="17///^S X="_"""""_SDREM_""""" D ^DIE K DIE,DR
- S ^DPT("ASDCN",SDCLI,DA,DA(1))=$S(SDWH["P":1,1:"") K DA
- ;removed rounding logic for time and changed direct global writes to fileman call SD*5.3*592
- D NOW^%DTC S SDNOW=%,DIE="^DPT("_DFN_",""S"",",DA=S,DA(1)=DFN,DR="3///^S X=SDWH;14////^S X=DUZ;15///^S X=SDNOW;16////^S X=SDSCR" D ^DIE K DIE,DR,DA
- S (DA,Y)=0 F X=0:0 S X=+$O(^SC(SDCLI,"S",S,1,X)) Q:'$D(^(X,0)) D C Q:Y&(DA)
- N REOPEN S REOPEN="" D SDEC(DFN,S,SDCLI,SDWH,SDSCR,SDREM,SDNOW,DUZ,REOPEN) ; vse-1886 reopen appt request when cancelling with VistA SD CANCEL APPOINTMENT option
- I $D(^DPT("ASDPSD","B",DIV,S\1,DFN)) D CK1
- Q:'Y S SL=$P(^SC(SDCLI,"S",S,1,Y,0),U,2) I DA,'$D(^("OB")) K ^SC(SDCLI,"S",S,1,DA,"OB")
- S SDDA=DA,SDTTM=S,SDRT="D",SDPL=Y,SDSC=SDCLI D RT^SDUTL D CANCEL^SDCNSLT S Y=SDPL,S=SDTTM,SDCLI=SDSC,DA=SDDA K SDDA ;SD/478
- S SDNODE=^SC(SDCLI,"S",S,1,Y,0),^SC("ARAD",SDCLI,S,DFN)="N",TLNK=$P($G(^SC(SDCLI,"S",S,1,Y,"CONS")),U) K ^SC(SDCLI,"S",S,1,Y) K:$O(^SC(SDCLI,"S",S,0))'>0 ^SC(SDCLI,"S",S,0) D CLRK^SDCNP1 ;SD/478
- K:TLNK'="" ^SC("AWAS1",TLNK),TLNK ;SD/478
- ;S SDNODE=^SC(I,"S",S,1,Y,0),^SC("ARAD",I,S,DFN)="N" S DA(2)=I,DA(1)=S,DA=Y,DIK="^SC("_DA(2)_",""S"","_DA(1)_",1," D ^DIK K:$O(^SC(I,"S",S,0))'>0 ^SC(I,"S",S,0) D CLRK^SDCNP1 ;SD/478
- D EVT
- Q:'$D(^SC(SDCLI,"ST",SD\1,1))
- EN01 S S=^SC(SDCLI,"ST",SD\1,1),Y=SD#1-SB*100,ST=Y#1*SI\.6+(Y\1*SI),SS=SL*HSI/60
- I Y'<1 F I=ST+ST:SDDIF S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y="" S S=$E(S,1,I)_Y_$E(S,I+2,999),SS=SS-1 Q:SS'>0
- S ^(1)=S Q ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
- C I +^SC(SDCLI,"S",S,1,X,0)=DFN S Y=X Q ;changed variable name I to SDCLI SD*5.3*592
- Q:'$D(^("OB"))!DA S:^("OB")?1"O".E DA=X Q
- NO W !,"NO ",$S('SDPV:"PENDING",1:"PREVIOUS")," APPOINTMENTS",*7,*7,*7
- D END^SDCNP G RD^SDCNP
- Q
- CHKSO S COV=$S($P(^DPT(DFN,"S",NDT,0),"^",11)=1:" (COLLATERAL) ",1:"") F SDJ=3,4,5 I $P(^DPT(DFN,"S",NDT,0),"^",SDJ)]"" S L=L+.1,^UTILITY($J,"SDCNP",L)=$P(^(0),"^",SDJ)_"^"_$S(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG")_"^0^0"
- Q
- MORE S SDCTR=SDCTR+2 I AT W ?41,$P(^UTILITY($J,"SDCNP",Z),"^",2) G OVR
- W " ",$S($P(^UTILITY($J,"SDCNP",Z),"^",4)?.N:"("_$P(^(Z),"^",4)_" MIN) ",1:$P(^(Z),"^",4))," ",$S($D(^SC($P(^(Z),"^",2),0)):$P(^(0),"^",1),1:"DELETED CLINIC"),$P(^UTILITY($J,"SDCNP",Z),"^",3) ;SD/478
- N CSND,CSDT,CSSD,CONSULT,Y
- S CSND=^UTILITY($J,"SDCNP",Z),CSDT=$P(CSND,U),CSSD=$P(CSND,U,2),HLDCSND=CSND S CONSULT=$$CONSULT(CSSD,CSDT) I +$G(CONSULT) S Y=$P(^GMR(123,CONSULT,0),U) D DD^%DT W !?5,"CONSULT ",Y,"/ ",CONSULT
- D STATUS($X>55)
- OVR ;Following code added SD/517
- I '$D(CSND) I $G(HLDCSND) I (($P(HLDCSND,U,4)="")!($P(HLDCSND,U,6)="")) D
- .W !!,"**********************************************************************"
- .W !,"* WARNING: There is a data inconsistency or data corruption problem *"
- .W !,"* with the above appointment. Corrective action needs to be taken. *"
- .W !,"* Please cancel the appointment above. If it is a valid appointment,*"
- .W !,"* it will have to be re-entered via Appointment Management. *"
- .W !,"**********************************************************************"
- .S SDCTR=21
- .K HLDCSND
- ;
- I SDCTR>20,$O(^UTILITY($J,"SDCNP",Z)) S (SDCTRL,SDCTR)=0 W *7 D WH W:'SDCTRL @IOF
- Q
- ;
- CONSULT(CSSD,CSDT) ;
- N CSI S CONSULT=""
- S CSI=0 F S CSI=$O(^SC(CSSD,"S",CSDT,1,CSI)) Q:'+CSI I $P($G(^SC(CSSD,"S",CSDT,1,CSI,0)),U)=DFN S CONSULT=$P($G(^SC(CSSD,"S",CSDT,1,CSI,"CONS")),U) Q ;SD/478
- Q CONSULT
- CK1 S SDX=0 F SD1=S\1: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 SDX=1 Q
- Q:SDX F SD1=2,4 I $D(^SC("AAS",SD1,S\1,DFN)) S SDX=1 Q
- Q:SDX IF $D(^SCE(+$$EXAE^SDOE(DFN,S\1,S\1),0)) S SDX=1
- Q:SDX K ^DPT("ASDPSD","B",DIV,S\1,DFN) Q
- ;
- SDEC(DFN,S,SDCLI,SDWH,SDSCR,SDREM,SDNOW,SDDUZ,SDF) ;update SDEC APPOINTMENT /alb/sat SD/627
- N SDECAPPT
- S SDECAPPT=$$APPTGET^SDECUTL(DFN,S,SDCLI)
- D:+SDECAPPT SDECCAN^SDEC08(SDECAPPT,SDWH,SDSCR,SDREM,SDNOW,$S($G(SDDUZ)'="":SDDUZ,1:DUZ),"0"_$G(SDF,0)) ;alb/jsm 658 add flag to indicate called from SDAM APPT CANCEL
- ; SD*5.3*804 - Move deletion of VVSID to after Appointment Cancellation
- N SDECIENS,SDECFDA,SDECMSG
- S SDECIENS=SDECAPPT_","
- S SDECFDA(409.84,SDECIENS,2)="@"
- K SDECMSG
- D FILE^DIE("","SDECFDA","SDECMSG")
- Q
- ;end addition/modification /alb/sat SD/627
- ;
- STATUS(LF) ;
- W:LF !
- W ?55,"(",$E($$LOWER^VALM1($P($$STATUS^SDAM1(DFN,+^UTILITY($J,"SDCNP",Z),+$P(^(Z),U,2),$G(^DPT(DFN,"S",+^(Z),0))),";",3)),1,23),")"
- W:'LF !
- Q
- ;
- EVT ; -- separate tag if need to NEW vars
- N I,STR,SS,SL,SD,SB,SI,HSI,J,APP,S,A1,STARTDAY,CNT,DIV,SDERR,SDDIF
- D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCPHDL)
- Q
- ;
- CANCELVVS(DFN,A1,SDWH,SDSCR,SDCANCELVVS,SDVVSAPPT) ;
- N SDT,SDIEN,SDSTATUS,QUIT,VVSERR
- ; Find the appt ien based on DFN and Date/Time
- S SDT=$P($G(^UTILITY($J,"SDCNP",A1)),U,1)
- S SDIEN="",QUIT=0,SDCANCELVVS=""
- F S SDIEN=$O(^SDEC(409.84,"APTDT",DFN,SDT,SDIEN),-1) Q:'SDIEN D Q:QUIT
- . S SDSTATUS=$$GET1^DIQ(409.84,SDIEN,.17,"I")
- . I SDSTATUS="" S QUIT=1
- ; If appt is a VVS appt, Cancel it in VVS
- I SDIEN>0 D
- . I $$GET1^DIQ(409.84,SDIEN,2,"E")'="" D
- . . S SDVVSAPPT=1
- . . S SDCANCELVVS=$$RESTPOST^SDESCANCELVVS(SDIEN,$S(SDWH="C":"CANCELLED BY CLINIC",1:"CANCELLED BY PATIENT"),$$GET1^DIQ(409.2,SDSCR,.01,"E"))
- . . I 'SDCANCELVVS H 2 Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCNP0 8474 printed Feb 19, 2025@00:15:37 Page 2
- SDCNP0 ;ALB/LDB,ANU,MGD - CANCEL APPT. FOR A PATIENT ;MAY 30, 2024
- +1 ;;5.3;Scheduling;**132,167,478,517,572,592,627,658,801,803,804,884**;Aug 13, 1993;Build 1
- +2 ;;Per VHA Directive 6402, this routine should not be modified
- +3 ; Reference/ICR
- +4 ; ^VALM1 - 10116
- +5 ;
- EN2 DO WAIT^DICD
- SET NDT=HDT/1
- SET L=0
- FOR J=1:1
- SET NDT=$ORDER(^DPT(DFN,"S",NDT))
- if NDT'>0!(SDPV&(NDT'<SDTM))
- QUIT
- SET SD0=^(NDT,0)
- IF $PIECE(SD0,"^",2)'["C"
- SET SC=+SD0
- SET L=L\1+1
- SET APL=""
- DO FLEN^SDCNP1A
- SET ^UTILITY($JOB,"SDCNP",L)=NDT_"^"_SC_"^"_COV_"^"_APL_"^^"_APL
- DO CHKSO
- WH1 if L'>0
- GOTO NO
- SET (SDCTRL,SDCTR)=0
- SET APP=""
- NEW SDITEM
- if 'SDERR
- WRITE @IOF
- +1 WRITE !
- FOR Z=0:0
- SET Z=$ORDER(^UTILITY($JOB,"SDCNP",Z))
- if Z'>0
- QUIT
- SET SDITEM=$JUSTIFY($SELECT(Z\1=Z:"("_$JUSTIFY(Z,2)_") ",1:""),5)
- Begin DoDot:1
- +2 IF SDITEM["("
- WRITE !,SDITEM
- SET HLDCSND=""
- +3 IF SDITEM'["("
- WRITE SDITEM
- +4 SET AT=$SELECT($PIECE(^(Z),"^",2)'?.N:1,1:0)
- SET Y=$PIECE($PIECE(^(Z),"^"),".")
- DO DT^SDM0
- SET X=$PIECE(^(Z),"^")
- SET ^(Z,"CNT")=""
- XECUTE ^DD("FUNC",2,1)
- WRITE " ",$JUSTIFY(X,8)
- DO MORE
- if AT
- WRITE !
- if SDCTRL
- QUIT
- End DoDot:1
- if SDCTRL
- QUIT
- +5 if SDERR
- SET SDCTRL=1
- IF Z>0
- if SDCTRL&(APP']"")
- GOTO NOPE^SDCNP1
- if SDCTRL
- GOTO DEL
- +6 DO WH
- if APP']""
- GOTO NOPE^SDCNP1
- GOTO DEL
- WH WRITE !!,"SELECT APPOINTMENTS TO BE CANCELLED"
- if Z>0
- WRITE " OR HIT RETURN TO CONTINUE DISPLAY"
- READ ": ",APP:DTIME
- IF '$TEST!(APP="^")
- SET SDCTRL=1
- SET APP=""
- QUIT
- +1 SET SDMSG="W !,""Enter appt. numbers separated by commas and/or a range separated"",!,""by dashes (ie 2,4,6-9)"" H 2"
- IF APP["?"
- XECUTE SDMSG
- GOTO WH
- +2 SET SDCTRL=$SELECT(APP']"":0,1:1)
- QUIT
- DEL SET SDERR=0
- FOR J=1:1
- SET SDDH=$PIECE(APP,",",J)
- if SDDH']""
- QUIT
- DO MTCH^SDCNP1
- +1 if SDERR
- GOTO WH1
- DEL1 FOR J=1:1
- SET SDDH=$PIECE(APP,",",J)
- if SDDH']""
- QUIT
- SET SDDI=$PIECE(SDDH,"-")
- SET SDDM=$PIECE(SDDH,"-",2)
- DO CKK^SDCNP1A
- if SDERR
- QUIT
- DO CKK1^SDCNP1A
- if SDERR
- QUIT
- if 'SDDI
- QUIT
- FOR A1=SDDI:1:$SELECT(SDDM:SDDM,1:SDDI)
- DO BEGD
- +1 if SDERR
- GOTO WH1
- GOTO NOPE^SDCNP1
- BEGD SET (SD,S)=$PIECE(^UTILITY($JOB,"SDCNP",A1),"^",1)
- SET I=$PIECE(^UTILITY($JOB,"SDCNP",A1),"^",2)
- +1 SET SL=^SC(I,"SL")
- SET X=$PIECE(SL,U,3)
- SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
- SET SB=STARTDAY-1/100
- SET X=$PIECE(SL,U,6)
- SET HSI=$SELECT(X:X,1:4)
- SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
- SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
- SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)
- KILL Y
- +2 ; SD*5.3*803 - Check if Check In Date exists and not allow cancel
- +3 IF $PIECE($GET(^SC(+$PIECE(^UTILITY($JOB,"SDCNP",A1),U,2),"S",+^UTILITY($JOB,"SDCNP",A1),1,+$$FIND^SDAM2(.DFN,+^UTILITY($JOB,"SDCNP",A1),+$PIECE(^(A1),U,2)),"C")),U,1)
- WRITE !,*7,">>> Appointment #",A1," has a check in date and cannot be cancelled."
- QUIT
- +4 IF $$CODT^SDCOU(DFN,+^UTILITY($JOB,"SDCNP",A1),+$PIECE(^(A1),U,2))
- WRITE !,*7,">>> Appointment #",A1," has a check out date and cannot be cancelled."
- QUIT
- +5 DO PROT^SDCNP1A
- if SDPRT=1
- QUIT
- +6 ;
- +7 NEW SDCANCELVVS,SDVVSAPPT
- +8 SET (SDCANCELVVS,SDVVSAPPT)=""
- +9 DO CANCELVVS(DFN,A1,SDWH,SDSCR,.SDCANCELVVS,.SDVVSAPPT)
- +10 ;
- +11 DO CAN
- SET $PIECE(^UTILITY($JOB,"SDCNP",A1),"^",4)="*** JUST CANCELLED ***"
- QUIT
- CAN if $PIECE(^UTILITY($JOB,"SDCNP",A1),"^",4)["JUST CANCELLED"
- QUIT
- SET CNT=CNT+1
- 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 NEW SDATA,SDCPHDL,SDNOW,SDCLI
- SET SDCPHDL=$$HANDLE^SDAMEVT(1)
- DO BEFORE^SDAMEVT(.SDATA,DFN,S,I,"",SDCPHDL)
- +2 ;changed variable name I to SDCLI(Hospital location file IEN) as the value of I is manipulated by ^DIE SD*5.3*592
- SET SDCLI=I
- +3 if '$DATA(^DPT(DFN,"S",0))
- SET ^(0)="^2.98P^^"
- IF $DATA(SDREM)
- SET DIE="^DPT("_DFN_",""S"","
- SET (DA,Y)=S
- SET DA(1)=DFN
- SET DR="17///^S X="_"""""_SDREM_"""""
- DO ^DIE
- KILL DIE,DR
- +4 SET ^DPT("ASDCN",SDCLI,DA,DA(1))=$SELECT(SDWH["P":1,1:"")
- KILL DA
- +5 ;removed rounding logic for time and changed direct global writes to fileman call SD*5.3*592
- +6 DO NOW^%DTC
- SET SDNOW=%
- SET DIE="^DPT("_DFN_",""S"","
- SET DA=S
- SET DA(1)=DFN
- SET DR="3///^S X=SDWH;14////^S X=DUZ;15///^S X=SDNOW;16////^S X=SDSCR"
- DO ^DIE
- KILL DIE,DR,DA
- +7 SET (DA,Y)=0
- FOR X=0:0
- SET X=+$ORDER(^SC(SDCLI,"S",S,1,X))
- if '$DATA(^(X,0))
- QUIT
- DO C
- if Y&(DA)
- QUIT
- +8 ; vse-1886 reopen appt request when cancelling with VistA SD CANCEL APPOINTMENT option
- NEW REOPEN
- SET REOPEN=""
- DO SDEC(DFN,S,SDCLI,SDWH,SDSCR,SDREM,SDNOW,DUZ,REOPEN)
- +9 IF $DATA(^DPT("ASDPSD","B",DIV,S\1,DFN))
- DO CK1
- +10 if 'Y
- QUIT
- SET SL=$PIECE(^SC(SDCLI,"S",S,1,Y,0),U,2)
- IF DA
- IF '$DATA(^("OB"))
- KILL ^SC(SDCLI,"S",S,1,DA,"OB")
- +11 ;SD/478
- SET SDDA=DA
- SET SDTTM=S
- SET SDRT="D"
- SET SDPL=Y
- SET SDSC=SDCLI
- DO RT^SDUTL
- DO CANCEL^SDCNSLT
- SET Y=SDPL
- SET S=SDTTM
- SET SDCLI=SDSC
- SET DA=SDDA
- KILL SDDA
- +12 ;SD/478
- SET SDNODE=^SC(SDCLI,"S",S,1,Y,0)
- SET ^SC("ARAD",SDCLI,S,DFN)="N"
- SET TLNK=$PIECE($GET(^SC(SDCLI,"S",S,1,Y,"CONS")),U)
- KILL ^SC(SDCLI,"S",S,1,Y)
- if $ORDER(^SC(SDCLI,"S",S,0))'>0
- KILL ^SC(SDCLI,"S",S,0)
- DO CLRK^SDCNP1
- +13 ;SD/478
- if TLNK'=""
- KILL ^SC("AWAS1",TLNK),TLNK
- +14 ;S SDNODE=^SC(I,"S",S,1,Y,0),^SC("ARAD",I,S,DFN)="N" S DA(2)=I,DA(1)=S,DA=Y,DIK="^SC("_DA(2)_",""S"","_DA(1)_",1," D ^DIK K:$O(^SC(I,"S",S,0))'>0 ^SC(I,"S",S,0) D CLRK^SDCNP1 ;SD/478
- +15 DO EVT
- +16 if '$DATA(^SC(SDCLI,"ST",SD\1,1))
- QUIT
- EN01 SET S=^SC(SDCLI,"ST",SD\1,1)
- SET Y=SD#1-SB*100
- SET ST=Y#1*SI\.6+(Y\1*SI)
- SET SS=SL*HSI/60
- +1 IF Y'<1
- FOR I=ST+ST:SDDIF
- SET Y=$EXTRACT(STR,$FIND(STR,$EXTRACT(S,I+1)))
- if Y=""
- QUIT
- SET S=$EXTRACT(S,1,I)_Y_$EXTRACT(S,I+2,999)
- SET SS=SS-1
- if SS'>0
- QUIT
- +2 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
- SET ^(1)=S
- QUIT
- C ;changed variable name I to SDCLI SD*5.3*592
- IF +^SC(SDCLI,"S",S,1,X,0)=DFN
- SET Y=X
- QUIT
- +1 if '$DATA(^("OB"))!DA
- QUIT
- if ^("OB")?1"O".E
- SET DA=X
- QUIT
- NO WRITE !,"NO ",$SELECT('SDPV:"PENDING",1:"PREVIOUS")," APPOINTMENTS",*7,*7,*7
- +1 DO END^SDCNP
- GOTO RD^SDCNP
- +2 QUIT
- CHKSO SET COV=$SELECT($PIECE(^DPT(DFN,"S",NDT,0),"^",11)=1:" (COLLATERAL) ",1:"")
- FOR SDJ=3,4,5
- IF $PIECE(^DPT(DFN,"S",NDT,0),"^",SDJ)]""
- SET L=L+.1
- SET ^UTILITY($JOB,"SDCNP",L)=$PIECE(^(0),"^",SDJ)_"^"_$SELECT(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG")_"^0^0"
- +1 QUIT
- MORE SET SDCTR=SDCTR+2
- IF AT
- WRITE ?41,$PIECE(^UTILITY($JOB,"SDCNP",Z),"^",2)
- GOTO OVR
- +1 ;SD/478
- WRITE " ",$SELECT($PIECE(^UTILITY($JOB,"SDCNP",Z),"^",4)?.N:"("_$PIECE(^(Z),"^",4)_" MIN) ",1:$PIECE(^(Z),"^",4))," ",$SELECT($DATA(^SC($PIECE(^(Z),"^",2),0)):$PIECE(^(0),"^",1),1:"DELETED CLINIC"),$PIECE(^UTILITY($JOB,"SDCNP",Z),"^",3)
- +2 NEW CSND,CSDT,CSSD,CONSULT,Y
- +3 SET CSND=^UTILITY($JOB,"SDCNP",Z)
- SET CSDT=$PIECE(CSND,U)
- SET CSSD=$PIECE(CSND,U,2)
- SET HLDCSND=CSND
- SET CONSULT=$$CONSULT(CSSD,CSDT)
- IF +$GET(CONSULT)
- SET Y=$PIECE(^GMR(123,CONSULT,0),U)
- DO DD^%DT
- WRITE !?5,"CONSULT ",Y,"/ ",CONSULT
- +4 DO STATUS($X>55)
- OVR ;Following code added SD/517
- +1 IF '$DATA(CSND)
- IF $GET(HLDCSND)
- IF (($PIECE(HLDCSND,U,4)="")!($PIECE(HLDCSND,U,6)=""))
- Begin DoDot:1
- +2 WRITE !!,"**********************************************************************"
- +3 WRITE !,"* WARNING: There is a data inconsistency or data corruption problem *"
- +4 WRITE !,"* with the above appointment. Corrective action needs to be taken. *"
- +5 WRITE !,"* Please cancel the appointment above. If it is a valid appointment,*"
- +6 WRITE !,"* it will have to be re-entered via Appointment Management. *"
- +7 WRITE !,"**********************************************************************"
- +8 SET SDCTR=21
- +9 KILL HLDCSND
- End DoDot:1
- +10 ;
- +11 IF SDCTR>20
- IF $ORDER(^UTILITY($JOB,"SDCNP",Z))
- SET (SDCTRL,SDCTR)=0
- WRITE *7
- DO WH
- if 'SDCTRL
- WRITE @IOF
- +12 QUIT
- +13 ;
- CONSULT(CSSD,CSDT) ;
- +1 NEW CSI
- SET CONSULT=""
- +2 ;SD/478
- SET CSI=0
- FOR
- SET CSI=$ORDER(^SC(CSSD,"S",CSDT,1,CSI))
- if '+CSI
- QUIT
- IF $PIECE($GET(^SC(CSSD,"S",CSDT,1,CSI,0)),U)=DFN
- SET CONSULT=$PIECE($GET(^SC(CSSD,"S",CSDT,1,CSI,"CONS")),U)
- QUIT
- +3 QUIT CONSULT
- CK1 SET SDX=0
- FOR SD1=S\1: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 SDX=1
- QUIT
- +1 if SDX
- QUIT
- FOR SD1=2,4
- IF $DATA(^SC("AAS",SD1,S\1,DFN))
- SET SDX=1
- QUIT
- +2 if SDX
- QUIT
- IF $DATA(^SCE(+$$EXAE^SDOE(DFN,S\1,S\1),0))
- SET SDX=1
- +3 if SDX
- QUIT
- KILL ^DPT("ASDPSD","B",DIV,S\1,DFN)
- QUIT
- +4 ;
- SDEC(DFN,S,SDCLI,SDWH,SDSCR,SDREM,SDNOW,SDDUZ,SDF) ;update SDEC APPOINTMENT /alb/sat SD/627
- +1 NEW SDECAPPT
- +2 SET SDECAPPT=$$APPTGET^SDECUTL(DFN,S,SDCLI)
- +3 ;alb/jsm 658 add flag to indicate called from SDAM APPT CANCEL
- if +SDECAPPT
- DO SDECCAN^SDEC08(SDECAPPT,SDWH,SDSCR,SDREM,SDNOW,$SELECT($GET(SDDUZ)'="":SDDUZ,1:DUZ),"0"_$GET(SDF,0))
- +4 ; SD*5.3*804 - Move deletion of VVSID to after Appointment Cancellation
- +5 NEW SDECIENS,SDECFDA,SDECMSG
- +6 SET SDECIENS=SDECAPPT_","
- +7 SET SDECFDA(409.84,SDECIENS,2)="@"
- +8 KILL SDECMSG
- +9 DO FILE^DIE("","SDECFDA","SDECMSG")
- +10 QUIT
- +11 ;end addition/modification /alb/sat SD/627
- +12 ;
- STATUS(LF) ;
- +1 if LF
- WRITE !
- +2 WRITE ?55,"(",$EXTRACT($$LOWER^VALM1($PIECE($$STATUS^SDAM1(DFN,+^UTILITY($JOB,"SDCNP",Z),+$PIECE(^(Z),U,2),$GET(^DPT(DFN,"S",+^(Z),0))),";",3)),1,23),")"
- +3 if 'LF
- WRITE !
- +4 QUIT
- +5 ;
- EVT ; -- separate tag if need to NEW vars
- +1 NEW I,STR,SS,SL,SD,SB,SI,HSI,J,APP,S,A1,STARTDAY,CNT,DIV,SDERR,SDDIF
- +2 DO CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCPHDL)
- +3 QUIT
- +4 ;
- CANCELVVS(DFN,A1,SDWH,SDSCR,SDCANCELVVS,SDVVSAPPT) ;
- +1 NEW SDT,SDIEN,SDSTATUS,QUIT,VVSERR
- +2 ; Find the appt ien based on DFN and Date/Time
- +3 SET SDT=$PIECE($GET(^UTILITY($JOB,"SDCNP",A1)),U,1)
- +4 SET SDIEN=""
- SET QUIT=0
- SET SDCANCELVVS=""
- +5 FOR
- SET SDIEN=$ORDER(^SDEC(409.84,"APTDT",DFN,SDT,SDIEN),-1)
- if 'SDIEN
- QUIT
- Begin DoDot:1
- +6 SET SDSTATUS=$$GET1^DIQ(409.84,SDIEN,.17,"I")
- +7 IF SDSTATUS=""
- SET QUIT=1
- End DoDot:1
- if QUIT
- QUIT
- +8 ; If appt is a VVS appt, Cancel it in VVS
- +9 IF SDIEN>0
- Begin DoDot:1
- +10 IF $$GET1^DIQ(409.84,SDIEN,2,"E")'=""
- Begin DoDot:2
- +11 SET SDVVSAPPT=1
- +12 SET SDCANCELVVS=$$RESTPOST^SDESCANCELVVS(SDIEN,$SELECT(SDWH="C":"CANCELLED BY CLINIC",1:"CANCELLED BY PATIENT"),$$GET1^DIQ(409.2,SDSCR,.01,"E"))
- +13 IF 'SDCANCELVVS
- HANG 2
- QUIT
- End DoDot:2
- End DoDot:1
- +14 QUIT
