- SDCNSLT ;ALB/HAG - LINK APPOINTMENTS TO CONSULTS ;JAN 15, 2016
- ;;5.3;Scheduling;**478,496,630,627,686,737**;Aug 13, 1993;Build 13
- ;;Per VHA Directive 2004-038, this routine should not be modified
- A ;===GET ACTIVE AND PENDING CONSULT
- N A,ND,CNT,CONS,CPRSTAT,DTENTR,DTIN,DTLMT,DTR,NOS,NOSHOW,SENDER,SERVICE,SRV,P8,PROC,PT,PTNM,STATUS
- K TMP S NOSHOW="no-show",CNT=0,$P(DSH,"-",IOM-1)="",PT=DFN,X1=DT,X2=-365 D C^%DTC S DTLMT=X
- S A=":" F S A=$O(^GMR(123,"F",PT,A),-1) Q:'+A S ND=$G(^GMR(123,A,0)) Q:ND="" S PROC=$P($G(^GMR(123,A,1.11)),U),DTENTR=$P(ND,U) I DTENTR>DTLMT S CPRSTAT=$P(ND,U,12) D:CPRSTAT=5!(CPRSTAT=6)!(CPRSTAT=8)!(CPRSTAT=13)
- .Q:$D(^XTMP("SDECLKC-"_A)) ;do not display consult if locked by VS GUI ;alb/sat 627
- .I STPCOD'="" S SRV=$P(ND,U,5) Q:'+SRV I $D(^GMR(123.5,"AB1",STPCOD,SRV)) S PTIEN=$P(ND,U,2) D
- ..I CPRSTAT=8 S SHOW=0 Q:$D(^SC("AWAS1",A)) S NOS=$O(^GMR(123,A,40,":"),-1) Q:'+NOS S X2=$P($G(^GMR(123,A,40,NOS,0)),U),X1=DT D ^%DTC Q:X'=""&(X>180) D SCHED(PTIEN,STPCOD,.SHOW) Q:'SHOW
- ..;CPRSTAT 13 is a cancel
- ..I CPRSTAT=13 S NOS=$O(^GMR(123,A,40,":"),-1) Q:'+NOS S NOS=$O(^GMR(123,A,40,NOS),-1) Q:'+NOS S X2=$P($G(^GMR(123,A,40,NOS,0)),U),X1=DT D ^%DTC Q:X'=""&(X>180) S COMMENT=$G(^GMR(123,A,40,NOS,1,1,0)) Q:COMMENT'[NOSHOW
- ..S:+PTIEN PTNM=$P(^DPT(PTIEN,0),U) S SERVICE=$P(^GMR(123.5,SRV,0),U),STATUS=$P(^ORD(100.01,CPRSTAT,0),U),SENDER=$P(ND,U,14) S:+SENDER SENDER=$P(^VA(200,SENDER,0),U)
- ..S Y=DTENTR D DD^%DT S DTIN=Y,DTR=$E(DTENTR,4,5)_"/"_$E(DTENTR,6,7)_"/"_$E(DTENTR,2,3)_"@"_$P(Y,"@",2)
- ..S CNT=CNT+1,TMP(CNT)=PTIEN_U_SERVICE_U_SENDER_U_STATUS_U_DTR_U_A_U_DTIN_U_$P(ND,U,17)_U_PROC
- Q:'$D(TMP)
- QST N DIR,DTOUT,DUOUT,CNSULT
- S DIR(0)="Y",DIR("A")="Will this appointment be for a CONSULT/PROCEDURE",DIR("B")="YES",DIR("?")="Answer 'Y'es if appointment is for a Consult or Procedure." W ! D ^DIR S CNSULT=Y
- I CNSULT[U!(CNSULT=0)!(CNSULT="") K TMP Q
- HDR W !!,"Please select from the list of consult(s), press 0 for none.",! ;LLS 05-JAN-2015 SD*5.3*630
- W !,PTNM,!!,"# Service",?68,"Cons #",!,DSH ;LLS 05-JAN-2015 SD*5.3*630
- S A=0 F S A=$O(TMP(A)) Q:'+A S ND=TMP(A),P8=$P(ND,U,8) D ;LLS 05-JAN-2015 SD*5.3*630
- . W !,A,".",?3,$S(P8="P":$E($P(ND,U,9),1,63),1:$E($P(ND,U,2),1,63)),?68,$P(ND,U,6) W !,?4,"Request DT: ",$E($P(ND,U,5),1,14),?31,"FROM: ",$E($P(ND,U,3),1,33),?71,"TYPE: ",$S(P8="P":"P",P8="C":"C",1:"") ;LLS 05-JAN-2015 SD*5.3*630
- W !
- READ R !,"Select Consult: ",CONS:DTIME G:CONS="" A
- I CONS=0!(CONS[U) W " ... NONE." K TMP Q
- I "? "[CONS W !," Select consult by number on the left side." G READ
- I '$D(TMP(CONS)) W *7," ?? Select consult by number on the left side." G READ
- S CNSLTLNK=$P(TMP(CONS),U,6)
- Q
- SCHED(PTIEN,STPCOD,SHOW) ;===CONSULT IS SCHEDULE NOW CHECK IF IT HAS APPOINTMENT BY STOP CODE.
- N APT,CLNC,B,S1,S2,S3,S4,STOP,STOPCOD,X,Y
- S %DT="ST",X="T-1" D ^%DT S APT=Y,S1=0,STOP=0 F S APT=$O(^DPT(PTIEN,"S",APT)) Q:'+APT!(STOP) S S1=1,CLNC=$P(^DPT(PTIEN,"S",APT,0),U) I CLNC'="" S STOPCOD=$P(^SC(CLNC,0),U,7) I STOPCOD'="" S S2=0 I STOPCOD=STPCOD S S2=1 D
- .S S3=0,S4=0,B=0 F S B=$O(^SC(CLNC,"S",APT,1,B)) Q:'+B!(STOP) S S3=1 D
- ..I ($P($G(^SC(CLNC,"S",APT,1,B,0)),U)=PTIEN) S S4=1,STOP=1,SHOW=0
- I S1=0 S SHOW=1 Q ;show if no appointment in the patient side
- I S2=0 S SHOW=1 Q ;show if stop code does not match
- I S3=0 S SHOW=1 Q ;show if no appointment in the clinic
- I S4=0 S SHOW=1 Q ;show if patient does not match in appointment
- Q
- LINK(SC,SDY,SD,CNSLTLNK) ;===LINK APPOINTMENT TO CONSULT
- N DA,DIE,DR,TDA,X
- S TDA=SDY,DA(2)=SC,DA(1)=SD,DA=TDA,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,",DR="688////^S X=CNSLTLNK" D ^DIE
- Q
- EDITCS(SD,TMPD,TMPYCLNC,CNSLTLNK) ;===MARK CONSULT AS SCHEDULED
- N CSCHDT,SNDPRV,TME,X,Y,COMMENT,ER
- S %DT="ST",X="NOW" D ^%DT S CSCHDT=Y
- S SNDPRV=$P($G(^GMR(123,CNSLTLNK,0)),U,14),Y=SD D DD^%DT S TME=$P($P(Y,"@",2),":",1,2)
- S COMMENT(1)=$P(TMPYCLNC,U,2)_" Consult Appt. on "_$E(SD,4,5)_"/"_$E(SD,6,7)_"/"_$E(SD,2,3)_" @ "_TME
- S COMMENT(2)=TMPD
- D SCH^SDQQCN2(.ER,CNSLTLNK,SNDPRV,CSCHDT,0,,.COMMENT) K COMMENT
- Q
- SDECCAN(SCLNK,SCSNOD,SDTTM,SDSC,SDWH,SDPL,SDECNOTE) ; patch 686 wtc/zeb 3.21.18 cancel consult appointment. called from SDEC07A.
- S SNDPRV=$P($G(^GMR(123,SCLNK,0)),U,14) ;
- ;
- CANCEL ;===appt was cancelled then mark consult as edit/resubmit, add comment.
- N APPT,CONSULT,CPRSSTAT,ER,GM40,GMRND,SDPATNT,USER,SNDPRV,J
- ;Variables CNDIE, CNDA and CNINDX used in calling routine for Cancel letter printed comment in consult.
- ;TMPD is assumed by the existing code
- S:$D(SDECNOTE) TMPD=SDECNOTE_$S($D(TMPD):"; ",1:"")_$G(TMPD) ;*zeb 686 10/30/18 keep cancel comment from GUI
- S:$D(SCLNK) CONSULT=SCLNK
- I SDPL S:'$D(SCLNK) CONSULT=$P($G(^SC(SDSC,"S",SDTTM,1,SDPL,"CONS")),U) ; check for value of SDPL - wtc 737 1/21/20
- Q:'+CONSULT
- S:$D(SCSNOD) SDPATNT=$P(SCSNOD,U)
- I SDPL S:'$D(SCSNOD) SDPATNT=$P($G(^SC(SDSC,"S",SDTTM,1,SDPL,0)),U) ; check for value of SDPL - wtc 737 1/21/20
- S CPRSSTAT=$P($G(^GMR(123,CONSULT,0)),U,12) I CPRSSTAT'="" S CPRSSTAT=$P($G(^ORD(100.01,CPRSSTAT,0)),U) Q:CPRSSTAT'="SCHEDULED"
- S SNDPRV=$P($G(^GMR(123,CONSULT,0)),U,14)
- S USER=$P(^VA(200,DUZ,0),U),Y=SDTTM D DD^%DT S APPT=$E(SDTTM,4,5)_"/"_$E(SDTTM,6,7)_"/"_$E(SDTTM,2,3)_" @ "_$P(Y,"@",2)
- S COMMENT(1)=$P(^SC(SDSC,0),U)_" Appt. on "_APPT_" was cancelled"_$S($D(SDWH):$S(SDWH["P":" by the Patient.",SDWH["C":" by the Clinic.",1:"."),$D(SDADM):" for administrative purposes.",1:", whole clinic.")
- S CNINDX=2 S:$D(TMPD) COMMENT(2)="Remarks: "_TMPD,CNINDX=CNINDX+1 K TMPD,SDECNOTE ;*zeb 686 10/30/18 clean up SDECNOTE in case SDECCAN not used
- N SDERR S SDERR=$$STATUS^GMRCGUIS(CONSULT,6,3,SNDPRV,"","",.COMMENT)
- S CNDIE="^GMR(123,"_CONSULT_",40,",CNDA=+$G(COMMENT(0))
- K COMMENT,DA
- S AUTO(SDSC,SDTTM,SDPATNT)=CONSULT
- I SDPL S DA(2)=SDSC,DA(1)=SDTTM,DA=SDPL,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,",DR="688///@" D ^DIE ; check for value of SDPL - wtc 737 1/21/20
- K SCSNOD,SDADM,SCLNK
- Q
- AUTOREB(SC,NDATE,LNK,CY) ;===AUTO REBOOK
- N DIC,DA,DIE,DR,Y,TME,SNDPRV,CSCHDT,COMMENT,ER
- S DA(2)=SC,DA(1)=NDATE,DA=CY,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,",DR="688////^S X=LNK" D ^DIE
- S Y=NDATE D DD^%DT S TME=$P(Y,"@",2)
- S COMMENT(1)=$P(^SC(SC,0),U)_" Consult Appt. on "_$E(NDATE,4,5)_"/"_$E(NDATE,6,7)_"/"_$E(NDATE,2,3)_" @ "_TME_" (Auto Rebooked)."
- S %DT="ST",X="NOW" D ^%DT S CSCHDT=Y
- S SNDPRV=$P($G(^GMR(123,LNK,0)),U,14)
- D SCH^SDQQCN2(.ER,LNK,SNDPRV,CSCHDT,0,,.COMMENT) K COMMENT
- Q
- NOSHOW(SC,SDDTM,CNPAT,CNSTLNK,CN,AUTO,NSDIE,NSDA) ;
- ;Appt. was a NoShow, then mark Consult as Edit/Resubmit, add comment using silent call to notify user.
- ;Variables NSDIE and NSDA used in calling routine for NoShow letter printed comment in consult.
- N CSNOD,CPRSSTAT,NOSHOW,CSRQSRV,TPRNT,CSPRT,USER,Y,APPT,COMMENT,DA,DIC,DUZ2,DIC,DR,GM40,GMRND,ER,SNDPRV,J
- S CSNOD=$G(^GMR(123,CNSTLNK,0)),CPRSSTAT=$P(CSNOD,U,12),SNDPRV=$P(CSNOD,U,14),NOSHOW="no-show",AUTO(SC,SDDTM,CNPAT)=CNSTLNK
- I CPRSSTAT'="" S CPRSSTAT=$P($G(^ORD(100.01,CPRSSTAT,0)),U) Q:CPRSSTAT'="SCHEDULED"
- S CSRQSRV=$P(CSNOD,U,5) I CSRQSRV'="" S TPRNT=$P($G(^GMR(123.5,CSRQSRV,123)),U,9) I TPRNT'="" S:$P($G(^%ZIS(1,TPRNT,0)),U)'="" CSPRT=$P(^(0),U) ;reprint consult
- S USER=$P(^VA(200,DUZ,0),U),Y=SDDTM D DD^%DT S APPT=$E(SDDTM,4,5)_"/"_$E(SDDTM,6,7)_"/"_$E(SDDTM,2,3)_" @ "_$P(Y,"@",2)
- S COMMENT(1)=$P(^SC(SC,0),U)_" Appt. on "_APPT_" was a "_NOSHOW_"." ;no-show is a key word used by a search do not change
- N SDERR S SDERR=$$STATUS^GMRCGUIS(CNSTLNK,6,3,SNDPRV,"","",.COMMENT)
- S NSDIE="^GMR(123,"_CNSTLNK_",40,",NSDA=+$G(COMMENT(0))
- K COMMENT,DA
- S DA(2)=SC,DA(1)=SDDTM,DA=CN,DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,",DR="688///@" D ^DIE
- I $D(CSPRT) D EN^GMRCP5(CNSTLNK,"C",CSPRT)
- K CNSTLNK Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCNSLT 7753 printed Jan 18, 2025@03:50:22 Page 2
- SDCNSLT ;ALB/HAG - LINK APPOINTMENTS TO CONSULTS ;JAN 15, 2016
- +1 ;;5.3;Scheduling;**478,496,630,627,686,737**;Aug 13, 1993;Build 13
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified
- A ;===GET ACTIVE AND PENDING CONSULT
- +1 NEW A,ND,CNT,CONS,CPRSTAT,DTENTR,DTIN,DTLMT,DTR,NOS,NOSHOW,SENDER,SERVICE,SRV,P8,PROC,PT,PTNM,STATUS
- +2 KILL TMP
- SET NOSHOW="no-show"
- SET CNT=0
- SET $PIECE(DSH,"-",IOM-1)=""
- SET PT=DFN
- SET X1=DT
- SET X2=-365
- DO C^%DTC
- SET DTLMT=X
- +3 SET A=":"
- FOR
- SET A=$ORDER(^GMR(123,"F",PT,A),-1)
- if '+A
- QUIT
- SET ND=$GET(^GMR(123,A,0))
- if ND=""
- QUIT
- SET PROC=$PIECE($GET(^GMR(123,A,1.11)),U)
- SET DTENTR=$PIECE(ND,U)
- IF DTENTR>DTLMT
- SET CPRSTAT=$PIECE(ND,U,12)
- if CPRSTAT=5!(CPRSTAT=6)!(CPRSTAT=8)!(CPRSTAT=13)
- Begin DoDot:1
- +4 ;do not display consult if locked by VS GUI ;alb/sat 627
- if $DATA(^XTMP("SDECLKC-"_A))
- QUIT
- +5 IF STPCOD'=""
- SET SRV=$PIECE(ND,U,5)
- if '+SRV
- QUIT
- IF $DATA(^GMR(123.5,"AB1",STPCOD,SRV))
- SET PTIEN=$PIECE(ND,U,2)
- Begin DoDot:2
- +6 IF CPRSTAT=8
- SET SHOW=0
- if $DATA(^SC("AWAS1",A))
- QUIT
- SET NOS=$ORDER(^GMR(123,A,40,":"),-1)
- if '+NOS
- QUIT
- SET X2=$PIECE($GET(^GMR(123,A,40,NOS,0)),U)
- SET X1=DT
- DO ^%DTC
- if X'=""&(X>180)
- QUIT
- DO SCHED(PTIEN,STPCOD,.SHOW)
- if 'SHOW
- QUIT
- +7 ;CPRSTAT 13 is a cancel
- +8 IF CPRSTAT=13
- SET NOS=$ORDER(^GMR(123,A,40,":"),-1)
- if '+NOS
- QUIT
- SET NOS=$ORDER(^GMR(123,A,40,NOS),-1)
- if '+NOS
- QUIT
- SET X2=$PIECE($GET(^GMR(123,A,40,NOS,0)),U)
- SET X1=DT
- DO ^%DTC
- if X'=""&(X>180)
- QUIT
- SET COMMENT=$GET(^GMR(123,A,40,NOS,1,1,0))
- if COMMENT'[NOSHOW
- QUIT
- +9 if +PTIEN
- SET PTNM=$PIECE(^DPT(PTIEN,0),U)
- SET SERVICE=$PIECE(^GMR(123.5,SRV,0),U)
- SET STATUS=$PIECE(^ORD(100.01,CPRSTAT,0),U)
- SET SENDER=$PIECE(ND,U,14)
- if +SENDER
- SET SENDER=$PIECE(^VA(200,SENDER,0),U)
- +10 SET Y=DTENTR
- DO DD^%DT
- SET DTIN=Y
- SET DTR=$EXTRACT(DTENTR,4,5)_"/"_$EXTRACT(DTENTR,6,7)_"/"_$EXTRACT(DTENTR,2,3)_"@"_$PIECE(Y,"@",2)
- +11 SET CNT=CNT+1
- SET TMP(CNT)=PTIEN_U_SERVICE_U_SENDER_U_STATUS_U_DTR_U_A_U_DTIN_U_$PIECE(ND,U,17)_U_PROC
- End DoDot:2
- End DoDot:1
- +12 if '$DATA(TMP)
- QUIT
- QST NEW DIR,DTOUT,DUOUT,CNSULT
- +1 SET DIR(0)="Y"
- SET DIR("A")="Will this appointment be for a CONSULT/PROCEDURE"
- SET DIR("B")="YES"
- SET DIR("?")="Answer 'Y'es if appointment is for a Consult or Procedure."
- WRITE !
- DO ^DIR
- SET CNSULT=Y
- +2 IF CNSULT[U!(CNSULT=0)!(CNSULT="")
- KILL TMP
- QUIT
- HDR ;LLS 05-JAN-2015 SD*5.3*630
- WRITE !!,"Please select from the list of consult(s), press 0 for none.",!
- +1 ;LLS 05-JAN-2015 SD*5.3*630
- WRITE !,PTNM,!!,"# Service",?68,"Cons #",!,DSH
- +2 ;LLS 05-JAN-2015 SD*5.3*630
- SET A=0
- FOR
- SET A=$ORDER(TMP(A))
- if '+A
- QUIT
- SET ND=TMP(A)
- SET P8=$PIECE(ND,U,8)
- Begin DoDot:1
- +3 ;LLS 05-JAN-2015 SD*5.3*630
- WRITE !,A,".",?3,$SELECT(P8="P":$EXTRACT($PIECE(ND,U,9),1,63),1:$EXTRACT($PIECE(ND,U,2),1,63)),?68,$PIECE(ND,U,6)
- WRITE !,?4,"Request DT: ",$EXTRACT($PIECE(ND,U,5),1,14),?31,"FROM: ",$EXTRACT($PIECE(ND,U,3),1,33),?71,"TYPE: ",$SELECT(P8="P":"P",P8="C":"C",1:"")
- End DoDot:1
- +4 WRITE !
- READ READ !,"Select Consult: ",CONS:DTIME
- if CONS=""
- GOTO A
- +1 IF CONS=0!(CONS[U)
- WRITE " ... NONE."
- KILL TMP
- QUIT
- +2 IF "? "[CONS
- WRITE !," Select consult by number on the left side."
- GOTO READ
- +3 IF '$DATA(TMP(CONS))
- WRITE *7," ?? Select consult by number on the left side."
- GOTO READ
- +4 SET CNSLTLNK=$PIECE(TMP(CONS),U,6)
- +5 QUIT
- SCHED(PTIEN,STPCOD,SHOW) ;===CONSULT IS SCHEDULE NOW CHECK IF IT HAS APPOINTMENT BY STOP CODE.
- +1 NEW APT,CLNC,B,S1,S2,S3,S4,STOP,STOPCOD,X,Y
- +2 SET %DT="ST"
- SET X="T-1"
- DO ^%DT
- SET APT=Y
- SET S1=0
- SET STOP=0
- FOR
- SET APT=$ORDER(^DPT(PTIEN,"S",APT))
- if '+APT!(STOP)
- QUIT
- SET S1=1
- SET CLNC=$PIECE(^DPT(PTIEN,"S",APT,0),U)
- IF CLNC'=""
- SET STOPCOD=$PIECE(^SC(CLNC,0),U,7)
- IF STOPCOD'=""
- SET S2=0
- IF STOPCOD=STPCOD
- SET S2=1
- Begin DoDot:1
- +3 SET S3=0
- SET S4=0
- SET B=0
- FOR
- SET B=$ORDER(^SC(CLNC,"S",APT,1,B))
- if '+B!(STOP)
- QUIT
- SET S3=1
- Begin DoDot:2
- +4 IF ($PIECE($GET(^SC(CLNC,"S",APT,1,B,0)),U)=PTIEN)
- SET S4=1
- SET STOP=1
- SET SHOW=0
- End DoDot:2
- End DoDot:1
- +5 ;show if no appointment in the patient side
- IF S1=0
- SET SHOW=1
- QUIT
- +6 ;show if stop code does not match
- IF S2=0
- SET SHOW=1
- QUIT
- +7 ;show if no appointment in the clinic
- IF S3=0
- SET SHOW=1
- QUIT
- +8 ;show if patient does not match in appointment
- IF S4=0
- SET SHOW=1
- QUIT
- +9 QUIT
- LINK(SC,SDY,SD,CNSLTLNK) ;===LINK APPOINTMENT TO CONSULT
- +1 NEW DA,DIE,DR,TDA,X
- +2 SET TDA=SDY
- SET DA(2)=SC
- SET DA(1)=SD
- SET DA=TDA
- SET DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
- SET DR="688////^S X=CNSLTLNK"
- DO ^DIE
- +3 QUIT
- EDITCS(SD,TMPD,TMPYCLNC,CNSLTLNK) ;===MARK CONSULT AS SCHEDULED
- +1 NEW CSCHDT,SNDPRV,TME,X,Y,COMMENT,ER
- +2 SET %DT="ST"
- SET X="NOW"
- DO ^%DT
- SET CSCHDT=Y
- +3 SET SNDPRV=$PIECE($GET(^GMR(123,CNSLTLNK,0)),U,14)
- SET Y=SD
- DO DD^%DT
- SET TME=$PIECE($PIECE(Y,"@",2),":",1,2)
- +4 SET COMMENT(1)=$PIECE(TMPYCLNC,U,2)_" Consult Appt. on "_$EXTRACT(SD,4,5)_"/"_$EXTRACT(SD,6,7)_"/"_$EXTRACT(SD,2,3)_" @ "_TME
- +5 SET COMMENT(2)=TMPD
- +6 DO SCH^SDQQCN2(.ER,CNSLTLNK,SNDPRV,CSCHDT,0,,.COMMENT)
- KILL COMMENT
- +7 QUIT
- SDECCAN(SCLNK,SCSNOD,SDTTM,SDSC,SDWH,SDPL,SDECNOTE) ; patch 686 wtc/zeb 3.21.18 cancel consult appointment. called from SDEC07A.
- +1 ;
- SET SNDPRV=$PIECE($GET(^GMR(123,SCLNK,0)),U,14)
- +2 ;
- CANCEL ;===appt was cancelled then mark consult as edit/resubmit, add comment.
- +1 NEW APPT,CONSULT,CPRSSTAT,ER,GM40,GMRND,SDPATNT,USER,SNDPRV,J
- +2 ;Variables CNDIE, CNDA and CNINDX used in calling routine for Cancel letter printed comment in consult.
- +3 ;TMPD is assumed by the existing code
- +4 ;*zeb 686 10/30/18 keep cancel comment from GUI
- if $DATA(SDECNOTE)
- SET TMPD=SDECNOTE_$SELECT($DATA(TMPD):"; ",1:"")_$GET(TMPD)
- +5 if $DATA(SCLNK)
- SET CONSULT=SCLNK
- +6 ; check for value of SDPL - wtc 737 1/21/20
- IF SDPL
- if '$DATA(SCLNK)
- SET CONSULT=$PIECE($GET(^SC(SDSC,"S",SDTTM,1,SDPL,"CONS")),U)
- +7 if '+CONSULT
- QUIT
- +8 if $DATA(SCSNOD)
- SET SDPATNT=$PIECE(SCSNOD,U)
- +9 ; check for value of SDPL - wtc 737 1/21/20
- IF SDPL
- if '$DATA(SCSNOD)
- SET SDPATNT=$PIECE($GET(^SC(SDSC,"S",SDTTM,1,SDPL,0)),U)
- +10 SET CPRSSTAT=$PIECE($GET(^GMR(123,CONSULT,0)),U,12)
- IF CPRSSTAT'=""
- SET CPRSSTAT=$PIECE($GET(^ORD(100.01,CPRSSTAT,0)),U)
- if CPRSSTAT'="SCHEDULED"
- QUIT
- +11 SET SNDPRV=$PIECE($GET(^GMR(123,CONSULT,0)),U,14)
- +12 SET USER=$PIECE(^VA(200,DUZ,0),U)
- SET Y=SDTTM
- DO DD^%DT
- SET APPT=$EXTRACT(SDTTM,4,5)_"/"_$EXTRACT(SDTTM,6,7)_"/"_$EXTRACT(SDTTM,2,3)_" @ "_$PIECE(Y,"@",2)
- +13 SET COMMENT(1)=$PIECE(^SC(SDSC,0),U)_" Appt. on "_APPT_" was cancelled"_$SELECT($DATA(SDWH):$SELECT(SDWH["P":" by the Patient.",SDWH["C":" by the Clinic.",1:"."),$DATA(SDADM):" for administrative purposes.",1:", whole clinic.")
- +14 ;*zeb 686 10/30/18 clean up SDECNOTE in case SDECCAN not used
- SET CNINDX=2
- if $DATA(TMPD)
- SET COMMENT(2)="Remarks: "_TMPD
- SET CNINDX=CNINDX+1
- KILL TMPD,SDECNOTE
- +15 NEW SDERR
- SET SDERR=$$STATUS^GMRCGUIS(CONSULT,6,3,SNDPRV,"","",.COMMENT)
- +16 SET CNDIE="^GMR(123,"_CONSULT_",40,"
- SET CNDA=+$GET(COMMENT(0))
- +17 KILL COMMENT,DA
- +18 SET AUTO(SDSC,SDTTM,SDPATNT)=CONSULT
- +19 ; check for value of SDPL - wtc 737 1/21/20
- IF SDPL
- SET DA(2)=SDSC
- SET DA(1)=SDTTM
- SET DA=SDPL
- SET DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
- SET DR="688///@"
- DO ^DIE
- +20 KILL SCSNOD,SDADM,SCLNK
- +21 QUIT
- AUTOREB(SC,NDATE,LNK,CY) ;===AUTO REBOOK
- +1 NEW DIC,DA,DIE,DR,Y,TME,SNDPRV,CSCHDT,COMMENT,ER
- +2 SET DA(2)=SC
- SET DA(1)=NDATE
- SET DA=CY
- SET DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
- SET DR="688////^S X=LNK"
- DO ^DIE
- +3 SET Y=NDATE
- DO DD^%DT
- SET TME=$PIECE(Y,"@",2)
- +4 SET COMMENT(1)=$PIECE(^SC(SC,0),U)_" Consult Appt. on "_$EXTRACT(NDATE,4,5)_"/"_$EXTRACT(NDATE,6,7)_"/"_$EXTRACT(NDATE,2,3)_" @ "_TME_" (Auto Rebooked)."
- +5 SET %DT="ST"
- SET X="NOW"
- DO ^%DT
- SET CSCHDT=Y
- +6 SET SNDPRV=$PIECE($GET(^GMR(123,LNK,0)),U,14)
- +7 DO SCH^SDQQCN2(.ER,LNK,SNDPRV,CSCHDT,0,,.COMMENT)
- KILL COMMENT
- +8 QUIT
- NOSHOW(SC,SDDTM,CNPAT,CNSTLNK,CN,AUTO,NSDIE,NSDA) ;
- +1 ;Appt. was a NoShow, then mark Consult as Edit/Resubmit, add comment using silent call to notify user.
- +2 ;Variables NSDIE and NSDA used in calling routine for NoShow letter printed comment in consult.
- +3 NEW CSNOD,CPRSSTAT,NOSHOW,CSRQSRV,TPRNT,CSPRT,USER,Y,APPT,COMMENT,DA,DIC,DUZ2,DIC,DR,GM40,GMRND,ER,SNDPRV,J
- +4 SET CSNOD=$GET(^GMR(123,CNSTLNK,0))
- SET CPRSSTAT=$PIECE(CSNOD,U,12)
- SET SNDPRV=$PIECE(CSNOD,U,14)
- SET NOSHOW="no-show"
- SET AUTO(SC,SDDTM,CNPAT)=CNSTLNK
- +5 IF CPRSSTAT'=""
- SET CPRSSTAT=$PIECE($GET(^ORD(100.01,CPRSSTAT,0)),U)
- if CPRSSTAT'="SCHEDULED"
- QUIT
- +6 ;reprint consult
- SET CSRQSRV=$PIECE(CSNOD,U,5)
- IF CSRQSRV'=""
- SET TPRNT=$PIECE($GET(^GMR(123.5,CSRQSRV,123)),U,9)
- IF TPRNT'=""
- if $PIECE($GET(^%ZIS(1,TPRNT,0)),U)'=""
- SET CSPRT=$PIECE(^(0),U)
- +7 SET USER=$PIECE(^VA(200,DUZ,0),U)
- SET Y=SDDTM
- DO DD^%DT
- SET APPT=$EXTRACT(SDDTM,4,5)_"/"_$EXTRACT(SDDTM,6,7)_"/"_$EXTRACT(SDDTM,2,3)_" @ "_$PIECE(Y,"@",2)
- +8 ;no-show is a key word used by a search do not change
- SET COMMENT(1)=$PIECE(^SC(SC,0),U)_" Appt. on "_APPT_" was a "_NOSHOW_"."
- +9 NEW SDERR
- SET SDERR=$$STATUS^GMRCGUIS(CNSTLNK,6,3,SNDPRV,"","",.COMMENT)
- +10 SET NSDIE="^GMR(123,"_CNSTLNK_",40,"
- SET NSDA=+$GET(COMMENT(0))
- +11 KILL COMMENT,DA
- +12 SET DA(2)=SC
- SET DA(1)=SDDTM
- SET DA=CN
- SET DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
- SET DR="688///@"
- DO ^DIE
- +13 IF $DATA(CSPRT)
- DO EN^GMRCP5(CNSTLNK,"C",CSPRT)
- +14 KILL CNSTLNK
- QUIT