SDECINI2 ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
;
;Reference is made to ICR #6185
Q
;
SDAPPT ;populate SDEC APPOINTMENT file with all existing patient appointments
N DFN,SDA,SDAPL,SDCAPL,SDCL,SDDATA,SDFDA,SDI,SDIEN,SDMSG,SDNOD,SDPRV,SDS,SDSP,SDTODAY,Y
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"Updating SDEC APPOINTMENT file 409.84 with existing patient appointments..."
W !,Y
S SDTODAY=$P($$NOW^XLFDT,".",1)
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:DFN'>0 D
.S SDS=SDTODAY F S SDS=$O(^DPT(DFN,"S",SDS)) Q:SDS'>0 D
..D SDECADD
;cleanup previous appointment lengths that did not account for variable appt length
S SDI=SDTODAY F S SDI=$O(^SDEC(409.84,"B",SDI),-1) Q:SDI="" D
.S SDIEN="" F S SDIEN=$O(^SDEC(409.84,"B",SDI,SDIEN)) Q:SDIEN="" D
..S SDNOD=$G(^SDEC(409.84,SDIEN,0))
..S SDRES=$P(SDNOD,U,7)
..S SDCL=$$GET1^DIQ(409.831,+SDRES_",",.04,"I")
..Q:SDCL=""
..S DFN=$P(SDNOD,U,5)
..S SDS=$P(SDNOD,U,1)
..S SDSP=$$FNDAPPT(SDCL,DFN,SDS)
..S SDAPL=$P($G(^SC(SDCL,"S",SDS,1,+SDSP,0)),U,2)
..S SDCAPL=$S(SDAPL'="":SDAPL,1:$P($G(^SC(SDCL,"SL")),U,1))
..I SDCAPL'=$P(SDNOD,U,18) D APL(SDIEN,SDS,SDCAPL)
;
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,Y
W !,"END - Updating SDEC APPOINTMENT file 409.84 with existing patient appointments..."
Q
SDECADD ;add SDEC APPOINTMENT entry
N SDAPL,SDCAPL,SDAPTYP,SDCAN,SDCHK,SDCL,SDCLN,SDECAPPTID,SDECFDA,SDECIEN,SDECMSG,SDECRESD
N SDNOS,SDREC,SDSP,SDSTAT,SDVPRV,SDWL
K SDDATA,SDMSG
D GETS^DIQ(2.98,SDS_","_DFN_",","**","IE","SDDATA","SDMSG")
S SDA="SDDATA(2.98,"""_SDS_","_DFN_","")"
S SDFDA=$NA(SDFDA(409.84,"+1,"))
S SDCL=@SDA@(.01,"I")
S SDCLN=@SDA@(.01,"E")
S SDECRESD=$O(^SDEC(409.831,"B",SDCLN,0))
S SDSP=$$FNDAPPT(SDCL,DFN,SDS) ;get clinic appt pointer
;look for SDWL, consult, then recall. If none found, add APPT entry
S SDAPTYP=""
S SDWL=$$FNDSDWL(DFN,SDS,SDCL) I SDWL'="" S SDAPTYP=SDWL_";SDWL(409.3,"
I SDAPTYP="" I SDSP'="",$P($G(^SC(SDCL,"S",SDS,1,SDSP,"CONS")),U,1)'="" S SDAPTYP=$P($G(^SC(SDCL,"S",SDS,1,SDSP,"CONS")),U,1)_";GMR(123,"
I SDAPTYP="" S SDREC=$$RECALL^SDECUTL(DFN,SDS,SDCL) I SDREC'="" S SDAPTYP=SDREC_";SD(403.5,"
;I SDAPTYP="" S SDAPPT=$$FNDAREQ(DFN,SDS,SDCL) I SDAPPT'="" S SDAPTYP=SDAPPT_";SDEC(409.84,"
;Q:$$SDECCHK(DFN,SDS,SDECRESD,SDAPTYP) ;check appt already exists
S SDAPL=$P($G(^SC(SDCL,"S",SDS,1,+SDSP,0)),U,2)
S SDCAPL=$S(SDAPL'="":SDAPL,1:$P($G(^SC(SDCL,"SL")),U,1)) ;appt length
Q:$$SDECCHK(DFN,SDS,SDECRESD,,SDCAPL) ;check appt already exists
I SDAPTYP="" S SDWL=$$SDWLA^SDM1A(DFN,SDS,SDCL,@SDA@(27,"I"),@SDA@(9.5,"I")) I SDWL'="" S SDAPTYP=SDWL_";SDEC(409.85,"
S:SDAPTYP'="" @SDFDA@(.22)=SDAPTYP
;Create entry in SDEC APPOINTMENT
S SDSTAT=@SDA@(3,"I") ;status
S SDNOS=$S(SDSTAT="N":1,SDSTAT="NA":1,1:0) ;no show flag
S SDCAN=$S(SDSTAT="C":1,SDSTAT="CA":1,SDSTAT="PC":1,SDSTAT="PCA":1,1:0) ;cancel flag
S SDCHK=$S(SDSP'="":$G(^SC(SDCL,"S",SDS,1,SDSP,"C")),1:"") ;clinic C checkin node
;
S @SDFDA@(.01)=SDS ;start time
S @SDFDA@(.02)=$$FMADD^XLFDT(SDS,,,SDCAPL) ;end time
S:$P(SDCHK,U,1) @SDFDA@(.03)=$P(SDCHK,U,1) ;check-in
S:$P(SDCHK,U,5) @SDFDA@(.04)=$P(SDCHK,U,5) ;check-in time entered
S @SDFDA@(.05)=DFN
;S:SDECATID?.N @SDFDA@(.06)=SDECATID
S @SDFDA@(.07)=SDECRESD ;resource
S @SDFDA@(.08)=@SDA@(19,"I") ;entered by
S @SDFDA@(.09)=@SDA@(20,"I") ;date appt made
S @SDFDA@(.1)=+SDNOS ;no show 1=YES 0=NO
S:SDNOS @SDFDA@(.101)=@SDA@(15,"I") ;no show date/time
S:SDNOS @SDFDA@(.102)=@SDA@(14,"I") ;no show user
S:@SDA@(12,"I")'="" @SDFDA@(.11)=@SDA@(12,"I") ;auto rebook date/time
S:SDCAN @SDFDA@(.12)=@SDA@(15,"I") ;cancel date/time (same as no show date/time)
S:SDCAN @SDFDA@(.121)=@SDA@(14,"I") ;cancel by user
S:SDCAN @SDFDA@(.122)=@SDA@(16,"I") ;cancellation reason
S:@SDA@(25,"I")="W" @SDFDA@(.13)="y" ;walk-in
S:$P(SDCHK,U,3)'="" @SDFDA@(.14)=$P(SDCHK,U,3) ;checked out date/time
S SDVPRV=$$FNDVPRV(DFN,SDS)
S:$P(SDVPRV,U,1)'="" @SDFDA@(.15)=$P(SDVPRV,U,1) ;v provider
S:$P(SDVPRV,U,2)'="" @SDFDA@(.16)=$P(SDVPRV,U,2) ;provider
S @SDFDA@(.17)=""
S @SDFDA@(.18)=SDCAPL ;appt length
S @SDFDA@(.19)=""
S @SDFDA@(.2)=@SDA@(27,"I") ;desired date of appt
D UPDATE^DIE("","SDFDA")
K SDECIEN,SDECMSG
Q
;
FNDVPRV(DFN,APPDT) ;get v provider for given patient and date/time
N SDI,SDNOD,SDRET
S SDRET=""
S SDI=0 F S SDI=$O(^AUPNVPRV("B",DFN,SDI)) Q:SDI'>0 D Q:SDRET'=""
.Q:$$GET1^DIQ(9000010.06,SDI_",",12,"I")'=APPDT
.S SDRET=SDI_U_$$GET1^DIQ(9000010.06,SDI_",",.01,"I")
Q SDRET
;
FNDAPPT(SDCL,DFN,SDS) ;get clinic appointment pointer
N SDI,SDRET
S SDRET=""
S SDI=0 F S SDI=$O(^SC(SDCL,"S",SDS,1,SDI)) Q:SDI'>0 D Q:SDRET'=""
.I DFN=$$GET1^DIQ(44.003,SDI_","_SDS_","_SDCL_",",.01,"I") S SDRET=SDI
Q SDRET
;
FNDSDWL(DFN,SDS,SDCL) ;get wait list entry
N SDI,SDNOD,SDRET
S SDRET=""
S SDI=0 F S SDI=$O(^SDWL(409.3,"B",DFN,SDI)) Q:SDI'>0 D Q:SDRET'=""
.S SDNOD=$G(^SDWL(409.3,SDI,"SDAPT"))
.I $P($G(^SDWL(409.3,SDI,0)),U,23)=SDS,$P(SDNOD,U,2)=SDCL S SDRET=SDI
Q SDRET
;
FNDAREQ(DFN,SDS,SDCL) ;get SDEC APPT REQUEST entry
N SDI,SDNOD,SDRET
S SDRET=""
S SDI=0 F S SDI=$O(^SDEC(409.85,"B",DFN,SDI)) Q:SDI'>0 D Q:SDRET'=""
.S SDNOD=$G(^SDEC(409.85,SDI,"SDAPT"))
.I $P(SDNOD,U,1)=SDS,$P(SDNOD,U,2)=SDCL S SDRET=SDI
Q SDRET
;
SDECCHK(DFN,SDS,SDRES,SDAPTYP,SDCAPL) ;check for existing SDEC APPOINTMENT entry
N SDFDA,SDI,SDNOD,SDNOD2,SDRET,SDTYP
;S:$G(SDAPTYP)="" SDAPTYP=";SDEC(409.85,"
S SDRET=0
S SDI=0 F S SDI=$O(^SDEC(409.84,"CPAT",DFN,SDI)) Q:SDI'>0 D Q:+SDRET
.S SDNOD=$G(^SDEC(409.84,SDI,0))
.;S SDNOD2=$G(^SDEC(409.84,SDI,2))
.I $P(SDNOD,U,1)=SDS,$P(SDNOD,U,7)=SDRES S SDRET=SDI D
..;I $P($P(SDNOD2,U,1),";",2)=$P(SDAPTYP,";",2) S SDRET=SDI
..;check request type
..S SDTYP=$P($G(^SDEC(409.84,SDI,2)),U,1)
..I $P(SDTYP,";",2)="SDWL(409.3," D
...I $D(^SDWL(409.3,$P(SDTYP,";",1),0)),$$GET1^DIQ(409.3,$P(SDTYP,";",1),.01,"I")=DFN Q
...I $D(^SDEC(409.85,$P(SDTYP,";",1),0)),$$GET1^DIQ(409.85,$P(SDTYP,";",1),.01,"I")=DFN D
....S SDFDA(409.84,SDI_",",.22)=$P(SDTYP,";",1)_";SDEC(409.85,"
....D UPDATE^DIE("","SDFDA")
..I $P(SDNOD,U,18)'=SDCAPL D APL(SDI,SDS,SDCAPL)
Q SDRET
APL(SDIEN,SDS,SDCAPL) ;
N SDFDA
S SDFDA(409.84,SDIEN_",",.18)=SDCAPL
S SDFDA(409.84,SDIEN_",",.02)=$$FMADD^XLFDT(SDS,,,SDCAPL)
D UPDATE^DIE("","SDFDA")
Q
;
CHK ;check cross-reference integrity
N SDA,SDDT,SDI,SDNAM,SDNOD,SDNOD1,SDNOD2,Y
W !!,"No changes taking place during existing cross-reference validity checks."
;B xref in file 44
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"BEGIN existing cross-reference validity checks for B xref of file 44."
W !,Y
S SDNAM="" F S SDNAM=$O(^SC("B",SDNAM)) Q:SDNAM="" D
.S SDI="" F S SDI=$O(^SC("B",SDNAM,SDI)) Q:SDI="" D
..I '$D(^SC(+SDI,0)) S SDA(44,"B","INVALID",SDI,SDNAM)="" Q
..S SDNOD=$E($$GET1^DIQ(44,+SDI_",",.01),1,30)
..I SDNOD="" S SDA(44,"B","MISMATCH",+SDI,SDNAM,"<no name>")="" Q
..I $E(SDNOD,1,30)'=$E(SDNAM,1,30) S SDA(44,"B","MISMATCH",+SDI,SDNAM,SDNOD)="" Q
I '$D(SDA(44,"B")) W !," No issues found."
I $D(SDA(44,"B")) W !," See summary below."
;B xref in file 409.3 SD WAIT LIST
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"BEGIN existing cross-reference validity checks for B xref of file 409.3."
W !,Y
S SDNAM="" F S SDNAM=$O(^SDWL(409.3,"B",SDNAM)) Q:SDNAM="" D
.S SDI="" F S SDI=$O(^SDWL(409.3,"B",SDNAM,SDI)) Q:SDI="" D
..I '$D(^SDWL(409.3,+SDI,0)) S SDA(409.3,"B","INVALID",SDI,SDNAM)="" Q
..S SDNOD=$E($$GET1^DIQ(409.3,+SDI_",",.01,"I"),1,30)
..I SDNOD="" S SDA(409.3,"B","MISMATCH",+SDI,SDNAM,"<no patient>")="" Q
..I SDNOD'=SDNAM S SDA(409.3,"B","MISMATCH",+SDI,SDNAM,SDNOD)="" Q
I '$D(SDA(409.3,"B")) W !," No issues found."
I $D(SDA(409.3,"B")) W !," See summary below."
;B xref in file 403.5 RECALL REMINDERS
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"BEGIN existing cross-reference validity checks for B xref of file 403.5."
W !,Y
S SDNAM="" F S SDNAM=$O(^SD(403.5,"B",SDNAM)) Q:SDNAM="" D
.S SDI="" F S SDI=$O(^SD(403.5,"B",SDNAM,SDI)) Q:SDI="" D
..I '$D(^SD(403.5,+SDI,0)) S SDA(403.5,"B","INVALID",SDI,SDNAM)="" Q
..S SDNOD=$E($$GET1^DIQ(403.5,+SDI_",",.01,"I"),1,30)
..I SDNOD="" S SDA(403.5,"B","MISMATCH",+SDI,SDNAM,"<no patient>")="" Q
..I SDNOD'=SDNAM S SDA(403.5,"B","MISMATCH",+SDI,SDNAM,SDNOD)="" Q
I '$D(SDA(403.5,"B")) W !," No issues found."
I $D(SDA(403.5,"B")) W !," See summary below."
;D xref in file 403.5 RECALL REMINDERS
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"BEGIN existing cross-reference validity checks for D xref of file 403.5."
W !,Y
S SDNAM="" F S SDNAM=$O(^SD(403.5,"D",SDNAM)) Q:SDNAM="" D
.S SDI="" F S SDI=$O(^SD(403.5,"D",SDNAM,SDI)) Q:SDI="" D
..I '$D(^SD(403.5,+SDI,0)) S SDA(403.5,"D","INVALID",SDI,SDNAM)="" Q
..S SDNOD=$E($$GET1^DIQ(403.5,+SDI_",",5,"I"),1,30)
..I SDNOD="" S SDA(403.5,"D","MISMATCH",+SDI,SDNAM,"<no patient>")="" Q
..I SDNOD'=SDNAM S SDA(403.5,"D","MISMATCH",+SDI,SDNAM,SDNOD)="" Q
I '$D(SDA(403.5,"D")) W !," No issues found."
I $D(SDA(403.5,"D")) W !," See summary below."
;AD xref in file 123 REQUEST/CONSULTATION ICR 6185
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"BEGIN existing cross-reference validity checks for AD xref of file 123."
W !,Y
S SDNAM="" F S SDNAM=$O(^GMR(123,"AD",SDNAM)) Q:SDNAM="" D
.S SDDT="" F S SDDT=$O(^GMR(123,"AD",SDNAM,SDDT)) Q:SDDT="" D
..S SDI="" F S SDI=$O(^GMR(123,"AD",SDNAM,SDDT,SDI)) Q:SDI="" D
...I '$D(^GMR(123,+SDI,0)) S SDA(123,"AD","INVALID",SDI,SDNAM)="" Q
...S SDNOD1=$$GET1^DIQ(123,+SDI_",",.02,"I")
...I SDNOD1="" S SDA(123,"AD","MISMATCH",+SDI,SDNAM,"<no patient>")="" Q
...I SDNOD1'=SDNAM S SDA(123,"AD","MISMATCH",+SDI,SDNAM,SDNOD1)="" Q
...S SDNOD2=$$GET1^DIQ(123,+SDI_",",3,"I")
...I SDNOD2="" S SDA(123,"AD","MISMATCH",+SDI,SDDT,"<no date of request>")="" Q
...S SDNOD2=9999999-SDNOD2
...I SDNOD2'=SDDT S SDA(123,"AD","MISMATCH",+SDI,SDDT,SDNOD2)="" Q
I '$D(SDA(123,"AD")) W !," No issues found."
I $D(SDA(123,"AB")) W !," See summary below."
;E xref in file 123 REQUEST/CONSULTATION ICR 6185
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"BEGIN existing cross-reference validity checks for E xref of file 123."
W !,Y
S SDNAM="" F S SDNAM=$O(^GMR(123,"E",SDNAM)) Q:SDNAM="" D
.S SDI="" F S SDI=$O(^GMR(123,"E",SDNAM,SDI)) Q:SDI="" D
..I '$D(^GMR(123,+SDI,0)) S SDA(123,"E","INVALID",SDI,SDNAM)="" Q
..S SDNOD=$$GET1^DIQ(123,+SDI_",",3,"I")
..I SDNOD="" S SDA(123,"E","MISMATCH",+SDI,SDNAM,"<no patient>")="" Q
..I SDNOD'=SDNAM S SDA(123,"E","MISMATCH",+SDI,SDNAM,SDNOD)="" Q
I '$D(SDA(123,"E")) W !," No issues found."
I $D(SDA(123,"E")) W !," See summary below."
;AB xref in file 200 NEW PERSON
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"BEGIN existing cross-reference validity checks for AB xref of file 200."
W !,Y
S SDNAM="" F S SDNAM=$O(^VA(200,"AB",SDNAM)) Q:SDNAM="" D
.S SDDT="" F S SDDT=$O(^VA(200,"AB",SDNAM,SDDT)) Q:SDDT="" D
..S SDI="" F S SDI=$O(^VA(200,"AB",SDNAM,SDDT,SDI)) Q:SDI="" D
...I '$D(^VA(200,+SDDT,51,SDI,0)) S SDA(200,"AB","INVALID",SDDT,SDNAM)="" ;SDDT=id to 200; SDNAM=id to key
I '$D(SDA(200,"AB")) W !," No issues found."
I $D(SDA(200,"AB")) W !," See summary below."
;B xref in file 200 NEW PERSON
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"BEGIN existing cross-reference validity checks for B xref of file 200."
W !,Y
S SDNAM="" F S SDNAM=$O(^VA(200,"B",SDNAM)) Q:SDNAM="" D
.S SDI="" F S SDI=$O(^VA(200,"B",SDNAM,SDI)) Q:SDI="" D
..I '$D(^VA(200,+SDI,0)) S SDA(200,"B","INVALID",SDI,SDNAM)="" Q
..S SDNOD=$E($$GET1^DIQ(200,+SDI_",",.01,"I"),1,30)
..I SDNOD="" S SDA(200,"B","MISMATCH",+SDI,SDNAM,"<no new person>")="" Q
..I $E(SDNOD,1,30)'=$E(SDNAM,1,30) S SDA(200,"B","MISMATCH",+SDI,SDNAM,SDNOD)="" Q
I '$D(SDA(200,"B")) W !," No issues found."
I $D(SDA(200,"B")) W !," See summary below."
D CHKW(.SDA)
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,Y
W !,"END existing cross-reference validity checks.",!!
Q
CHKW(SDA) ;
N SDF,SDI,SDNAM,SDNOD,SDS
N T1,T2,T3
Q:'$O(SDA(0))
W !!," SUMMARY of existing cross-reference validity checks:"
W !," ----------------------------------------------------"
;set tabs
S T1=2,T2=14,T3=46
S SDF="" F S SDF=$O(SDA(SDF)) Q:SDF="" D
.S SDS="" F S SDS=$O(SDA(SDF,SDS)) Q:SDS="" D
..;Invalid pointers
..I $D(SDA(SDF,SDS,"INVALID"))>1 D
...W !!,"INVALID POINTERS found in "_SDS_" xref of file "_SDF
...W !,?T1,"ID",?T2,"XREF NAME"
...W !,?T1,"--",?T2,"---------"
...S SDI="" F S SDI=$O(SDA(SDF,SDS,"INVALID",SDI)) Q:SDI="" D
....S SDNAM="" F S SDNAM=$O(SDA(SDF,SDS,"INVALID",SDI,SDNAM)) Q:SDNAM="" D
.....W !,?T1,SDI,?T2,SDNAM
..I $D(SDA(SDF,SDS,"MISMATCH"))>1 D
...W !!,"NAMES DO NOT MATCH found in "_SDS_" xref of file "_SDF
...W !,?T1,"ID",?T2,"XREF NAME",?T3,"ENTRY NAME"
...W !,?T1,"--",?T2,"---------",?T3,"----------"
...S SDI="" F S SDI=$O(SDA(SDF,SDS,"MISMATCH",SDI)) Q:SDI="" D
....S SDNAM="" F S SDNAM=$O(SDA(SDF,SDS,"MISMATCH",SDI,SDNAM)) Q:SDNAM="" D
.....S SDNOD="" F S SDNOD=$O(SDA(SDF,SDS,"MISMATCH",SDI,SDNAM,SDNOD)) Q:SDNOD="" D
......W !,?T1,SDI,?T2,SDNAM,?T3,SDNOD
;I '$D(SDA) W !," No issues found."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECINI2 13685 printed Apr 09, 2024@22:03:27 Page 2
SDECINI2 ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
+1 ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
+2 ;
+3 ;Reference is made to ICR #6185
+4 QUIT
+5 ;
SDAPPT ;populate SDEC APPOINTMENT file with all existing patient appointments
+1 NEW DFN,SDA,SDAPL,SDCAPL,SDCL,SDDATA,SDFDA,SDI,SDIEN,SDMSG,SDNOD,SDPRV,SDS,SDSP,SDTODAY,Y
+2 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+3 WRITE !!,"Updating SDEC APPOINTMENT file 409.84 with existing patient appointments..."
+4 WRITE !,Y
+5 SET SDTODAY=$PIECE($$NOW^XLFDT,".",1)
+6 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
if DFN'>0
QUIT
Begin DoDot:1
+7 SET SDS=SDTODAY
FOR
SET SDS=$ORDER(^DPT(DFN,"S",SDS))
if SDS'>0
QUIT
Begin DoDot:2
+8 DO SDECADD
End DoDot:2
End DoDot:1
+9 ;cleanup previous appointment lengths that did not account for variable appt length
+10 SET SDI=SDTODAY
FOR
SET SDI=$ORDER(^SDEC(409.84,"B",SDI),-1)
if SDI=""
QUIT
Begin DoDot:1
+11 SET SDIEN=""
FOR
SET SDIEN=$ORDER(^SDEC(409.84,"B",SDI,SDIEN))
if SDIEN=""
QUIT
Begin DoDot:2
+12 SET SDNOD=$GET(^SDEC(409.84,SDIEN,0))
+13 SET SDRES=$PIECE(SDNOD,U,7)
+14 SET SDCL=$$GET1^DIQ(409.831,+SDRES_",",.04,"I")
+15 if SDCL=""
QUIT
+16 SET DFN=$PIECE(SDNOD,U,5)
+17 SET SDS=$PIECE(SDNOD,U,1)
+18 SET SDSP=$$FNDAPPT(SDCL,DFN,SDS)
+19 SET SDAPL=$PIECE($GET(^SC(SDCL,"S",SDS,1,+SDSP,0)),U,2)
+20 SET SDCAPL=$SELECT(SDAPL'="":SDAPL,1:$PIECE($GET(^SC(SDCL,"SL")),U,1))
+21 IF SDCAPL'=$PIECE(SDNOD,U,18)
DO APL(SDIEN,SDS,SDCAPL)
End DoDot:2
End DoDot:1
+22 ;
+23 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+24 WRITE !!,Y
+25 WRITE !,"END - Updating SDEC APPOINTMENT file 409.84 with existing patient appointments..."
+26 QUIT
SDECADD ;add SDEC APPOINTMENT entry
+1 NEW SDAPL,SDCAPL,SDAPTYP,SDCAN,SDCHK,SDCL,SDCLN,SDECAPPTID,SDECFDA,SDECIEN,SDECMSG,SDECRESD
+2 NEW SDNOS,SDREC,SDSP,SDSTAT,SDVPRV,SDWL
+3 KILL SDDATA,SDMSG
+4 DO GETS^DIQ(2.98,SDS_","_DFN_",","**","IE","SDDATA","SDMSG")
+5 SET SDA="SDDATA(2.98,"""_SDS_","_DFN_","")"
+6 SET SDFDA=$NAME(SDFDA(409.84,"+1,"))
+7 SET SDCL=@SDA@(.01,"I")
+8 SET SDCLN=@SDA@(.01,"E")
+9 SET SDECRESD=$ORDER(^SDEC(409.831,"B",SDCLN,0))
+10 ;get clinic appt pointer
SET SDSP=$$FNDAPPT(SDCL,DFN,SDS)
+11 ;look for SDWL, consult, then recall. If none found, add APPT entry
+12 SET SDAPTYP=""
+13 SET SDWL=$$FNDSDWL(DFN,SDS,SDCL)
IF SDWL'=""
SET SDAPTYP=SDWL_";SDWL(409.3,"
+14 IF SDAPTYP=""
IF SDSP'=""
IF $PIECE($GET(^SC(SDCL,"S",SDS,1,SDSP,"CONS")),U,1)'=""
SET SDAPTYP=$PIECE($GET(^SC(SDCL,"S",SDS,1,SDSP,"CONS")),U,1)_";GMR(123,"
+15 IF SDAPTYP=""
SET SDREC=$$RECALL^SDECUTL(DFN,SDS,SDCL)
IF SDREC'=""
SET SDAPTYP=SDREC_";SD(403.5,"
+16 ;I SDAPTYP="" S SDAPPT=$$FNDAREQ(DFN,SDS,SDCL) I SDAPPT'="" S SDAPTYP=SDAPPT_";SDEC(409.84,"
+17 ;Q:$$SDECCHK(DFN,SDS,SDECRESD,SDAPTYP) ;check appt already exists
+18 SET SDAPL=$PIECE($GET(^SC(SDCL,"S",SDS,1,+SDSP,0)),U,2)
+19 ;appt length
SET SDCAPL=$SELECT(SDAPL'="":SDAPL,1:$PIECE($GET(^SC(SDCL,"SL")),U,1))
+20 ;check appt already exists
if $$SDECCHK(DFN,SDS,SDECRESD,,SDCAPL)
QUIT
+21 IF SDAPTYP=""
SET SDWL=$$SDWLA^SDM1A(DFN,SDS,SDCL,@SDA@(27,"I"),@SDA@(9.5,"I"))
IF SDWL'=""
SET SDAPTYP=SDWL_";SDEC(409.85,"
+22 if SDAPTYP'=""
SET @SDFDA@(.22)=SDAPTYP
+23 ;Create entry in SDEC APPOINTMENT
+24 ;status
SET SDSTAT=@SDA@(3,"I")
+25 ;no show flag
SET SDNOS=$SELECT(SDSTAT="N":1,SDSTAT="NA":1,1:0)
+26 ;cancel flag
SET SDCAN=$SELECT(SDSTAT="C":1,SDSTAT="CA":1,SDSTAT="PC":1,SDSTAT="PCA":1,1:0)
+27 ;clinic C checkin node
SET SDCHK=$SELECT(SDSP'="":$GET(^SC(SDCL,"S",SDS,1,SDSP,"C")),1:"")
+28 ;
+29 ;start time
SET @SDFDA@(.01)=SDS
+30 ;end time
SET @SDFDA@(.02)=$$FMADD^XLFDT(SDS,,,SDCAPL)
+31 ;check-in
if $PIECE(SDCHK,U,1)
SET @SDFDA@(.03)=$PIECE(SDCHK,U,1)
+32 ;check-in time entered
if $PIECE(SDCHK,U,5)
SET @SDFDA@(.04)=$PIECE(SDCHK,U,5)
+33 SET @SDFDA@(.05)=DFN
+34 ;S:SDECATID?.N @SDFDA@(.06)=SDECATID
+35 ;resource
SET @SDFDA@(.07)=SDECRESD
+36 ;entered by
SET @SDFDA@(.08)=@SDA@(19,"I")
+37 ;date appt made
SET @SDFDA@(.09)=@SDA@(20,"I")
+38 ;no show 1=YES 0=NO
SET @SDFDA@(.1)=+SDNOS
+39 ;no show date/time
if SDNOS
SET @SDFDA@(.101)=@SDA@(15,"I")
+40 ;no show user
if SDNOS
SET @SDFDA@(.102)=@SDA@(14,"I")
+41 ;auto rebook date/time
if @SDA@(12,"I")'=""
SET @SDFDA@(.11)=@SDA@(12,"I")
+42 ;cancel date/time (same as no show date/time)
if SDCAN
SET @SDFDA@(.12)=@SDA@(15,"I")
+43 ;cancel by user
if SDCAN
SET @SDFDA@(.121)=@SDA@(14,"I")
+44 ;cancellation reason
if SDCAN
SET @SDFDA@(.122)=@SDA@(16,"I")
+45 ;walk-in
if @SDA@(25,"I")="W"
SET @SDFDA@(.13)="y"
+46 ;checked out date/time
if $PIECE(SDCHK,U,3)'=""
SET @SDFDA@(.14)=$PIECE(SDCHK,U,3)
+47 SET SDVPRV=$$FNDVPRV(DFN,SDS)
+48 ;v provider
if $PIECE(SDVPRV,U,1)'=""
SET @SDFDA@(.15)=$PIECE(SDVPRV,U,1)
+49 ;provider
if $PIECE(SDVPRV,U,2)'=""
SET @SDFDA@(.16)=$PIECE(SDVPRV,U,2)
+50 SET @SDFDA@(.17)=""
+51 ;appt length
SET @SDFDA@(.18)=SDCAPL
+52 SET @SDFDA@(.19)=""
+53 ;desired date of appt
SET @SDFDA@(.2)=@SDA@(27,"I")
+54 DO UPDATE^DIE("","SDFDA")
+55 KILL SDECIEN,SDECMSG
+56 QUIT
+57 ;
FNDVPRV(DFN,APPDT) ;get v provider for given patient and date/time
+1 NEW SDI,SDNOD,SDRET
+2 SET SDRET=""
+3 SET SDI=0
FOR
SET SDI=$ORDER(^AUPNVPRV("B",DFN,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+4 if $$GET1^DIQ(9000010.06,SDI_",",12,"I")'=APPDT
QUIT
+5 SET SDRET=SDI_U_$$GET1^DIQ(9000010.06,SDI_",",.01,"I")
End DoDot:1
if SDRET'=""
QUIT
+6 QUIT SDRET
+7 ;
FNDAPPT(SDCL,DFN,SDS) ;get clinic appointment pointer
+1 NEW SDI,SDRET
+2 SET SDRET=""
+3 SET SDI=0
FOR
SET SDI=$ORDER(^SC(SDCL,"S",SDS,1,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+4 IF DFN=$$GET1^DIQ(44.003,SDI_","_SDS_","_SDCL_",",.01,"I")
SET SDRET=SDI
End DoDot:1
if SDRET'=""
QUIT
+5 QUIT SDRET
+6 ;
FNDSDWL(DFN,SDS,SDCL) ;get wait list entry
+1 NEW SDI,SDNOD,SDRET
+2 SET SDRET=""
+3 SET SDI=0
FOR
SET SDI=$ORDER(^SDWL(409.3,"B",DFN,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+4 SET SDNOD=$GET(^SDWL(409.3,SDI,"SDAPT"))
+5 IF $PIECE($GET(^SDWL(409.3,SDI,0)),U,23)=SDS
IF $PIECE(SDNOD,U,2)=SDCL
SET SDRET=SDI
End DoDot:1
if SDRET'=""
QUIT
+6 QUIT SDRET
+7 ;
FNDAREQ(DFN,SDS,SDCL) ;get SDEC APPT REQUEST entry
+1 NEW SDI,SDNOD,SDRET
+2 SET SDRET=""
+3 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.85,"B",DFN,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+4 SET SDNOD=$GET(^SDEC(409.85,SDI,"SDAPT"))
+5 IF $PIECE(SDNOD,U,1)=SDS
IF $PIECE(SDNOD,U,2)=SDCL
SET SDRET=SDI
End DoDot:1
if SDRET'=""
QUIT
+6 QUIT SDRET
+7 ;
SDECCHK(DFN,SDS,SDRES,SDAPTYP,SDCAPL) ;check for existing SDEC APPOINTMENT entry
+1 NEW SDFDA,SDI,SDNOD,SDNOD2,SDRET,SDTYP
+2 ;S:$G(SDAPTYP)="" SDAPTYP=";SDEC(409.85,"
+3 SET SDRET=0
+4 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.84,"CPAT",DFN,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+5 SET SDNOD=$GET(^SDEC(409.84,SDI,0))
+6 ;S SDNOD2=$G(^SDEC(409.84,SDI,2))
+7 IF $PIECE(SDNOD,U,1)=SDS
IF $PIECE(SDNOD,U,7)=SDRES
SET SDRET=SDI
Begin DoDot:2
+8 ;I $P($P(SDNOD2,U,1),";",2)=$P(SDAPTYP,";",2) S SDRET=SDI
+9 ;check request type
+10 SET SDTYP=$PIECE($GET(^SDEC(409.84,SDI,2)),U,1)
+11 IF $PIECE(SDTYP,";",2)="SDWL(409.3,"
Begin DoDot:3
+12 IF $DATA(^SDWL(409.3,$PIECE(SDTYP,";",1),0))
IF $$GET1^DIQ(409.3,$PIECE(SDTYP,";",1),.01,"I")=DFN
QUIT
+13 IF $DATA(^SDEC(409.85,$PIECE(SDTYP,";",1),0))
IF $$GET1^DIQ(409.85,$PIECE(SDTYP,";",1),.01,"I")=DFN
Begin DoDot:4
+14 SET SDFDA(409.84,SDI_",",.22)=$PIECE(SDTYP,";",1)_";SDEC(409.85,"
+15 DO UPDATE^DIE("","SDFDA")
End DoDot:4
End DoDot:3
+16 IF $PIECE(SDNOD,U,18)'=SDCAPL
DO APL(SDI,SDS,SDCAPL)
End DoDot:2
End DoDot:1
if +SDRET
QUIT
+17 QUIT SDRET
APL(SDIEN,SDS,SDCAPL) ;
+1 NEW SDFDA
+2 SET SDFDA(409.84,SDIEN_",",.18)=SDCAPL
+3 SET SDFDA(409.84,SDIEN_",",.02)=$$FMADD^XLFDT(SDS,,,SDCAPL)
+4 DO UPDATE^DIE("","SDFDA")
+5 QUIT
+6 ;
CHK ;check cross-reference integrity
+1 NEW SDA,SDDT,SDI,SDNAM,SDNOD,SDNOD1,SDNOD2,Y
+2 WRITE !!,"No changes taking place during existing cross-reference validity checks."
+3 ;B xref in file 44
+4 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+5 WRITE !!,"BEGIN existing cross-reference validity checks for B xref of file 44."
+6 WRITE !,Y
+7 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^SC("B",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+8 SET SDI=""
FOR
SET SDI=$ORDER(^SC("B",SDNAM,SDI))
if SDI=""
QUIT
Begin DoDot:2
+9 IF '$DATA(^SC(+SDI,0))
SET SDA(44,"B","INVALID",SDI,SDNAM)=""
QUIT
+10 SET SDNOD=$EXTRACT($$GET1^DIQ(44,+SDI_",",.01),1,30)
+11 IF SDNOD=""
SET SDA(44,"B","MISMATCH",+SDI,SDNAM,"<no name>")=""
QUIT
+12 IF $EXTRACT(SDNOD,1,30)'=$EXTRACT(SDNAM,1,30)
SET SDA(44,"B","MISMATCH",+SDI,SDNAM,SDNOD)=""
QUIT
End DoDot:2
End DoDot:1
+13 IF '$DATA(SDA(44,"B"))
WRITE !," No issues found."
+14 IF $DATA(SDA(44,"B"))
WRITE !," See summary below."
+15 ;B xref in file 409.3 SD WAIT LIST
+16 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+17 WRITE !!,"BEGIN existing cross-reference validity checks for B xref of file 409.3."
+18 WRITE !,Y
+19 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^SDWL(409.3,"B",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+20 SET SDI=""
FOR
SET SDI=$ORDER(^SDWL(409.3,"B",SDNAM,SDI))
if SDI=""
QUIT
Begin DoDot:2
+21 IF '$DATA(^SDWL(409.3,+SDI,0))
SET SDA(409.3,"B","INVALID",SDI,SDNAM)=""
QUIT
+22 SET SDNOD=$EXTRACT($$GET1^DIQ(409.3,+SDI_",",.01,"I"),1,30)
+23 IF SDNOD=""
SET SDA(409.3,"B","MISMATCH",+SDI,SDNAM,"<no patient>")=""
QUIT
+24 IF SDNOD'=SDNAM
SET SDA(409.3,"B","MISMATCH",+SDI,SDNAM,SDNOD)=""
QUIT
End DoDot:2
End DoDot:1
+25 IF '$DATA(SDA(409.3,"B"))
WRITE !," No issues found."
+26 IF $DATA(SDA(409.3,"B"))
WRITE !," See summary below."
+27 ;B xref in file 403.5 RECALL REMINDERS
+28 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+29 WRITE !!,"BEGIN existing cross-reference validity checks for B xref of file 403.5."
+30 WRITE !,Y
+31 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^SD(403.5,"B",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+32 SET SDI=""
FOR
SET SDI=$ORDER(^SD(403.5,"B",SDNAM,SDI))
if SDI=""
QUIT
Begin DoDot:2
+33 IF '$DATA(^SD(403.5,+SDI,0))
SET SDA(403.5,"B","INVALID",SDI,SDNAM)=""
QUIT
+34 SET SDNOD=$EXTRACT($$GET1^DIQ(403.5,+SDI_",",.01,"I"),1,30)
+35 IF SDNOD=""
SET SDA(403.5,"B","MISMATCH",+SDI,SDNAM,"<no patient>")=""
QUIT
+36 IF SDNOD'=SDNAM
SET SDA(403.5,"B","MISMATCH",+SDI,SDNAM,SDNOD)=""
QUIT
End DoDot:2
End DoDot:1
+37 IF '$DATA(SDA(403.5,"B"))
WRITE !," No issues found."
+38 IF $DATA(SDA(403.5,"B"))
WRITE !," See summary below."
+39 ;D xref in file 403.5 RECALL REMINDERS
+40 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+41 WRITE !!,"BEGIN existing cross-reference validity checks for D xref of file 403.5."
+42 WRITE !,Y
+43 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^SD(403.5,"D",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+44 SET SDI=""
FOR
SET SDI=$ORDER(^SD(403.5,"D",SDNAM,SDI))
if SDI=""
QUIT
Begin DoDot:2
+45 IF '$DATA(^SD(403.5,+SDI,0))
SET SDA(403.5,"D","INVALID",SDI,SDNAM)=""
QUIT
+46 SET SDNOD=$EXTRACT($$GET1^DIQ(403.5,+SDI_",",5,"I"),1,30)
+47 IF SDNOD=""
SET SDA(403.5,"D","MISMATCH",+SDI,SDNAM,"<no patient>")=""
QUIT
+48 IF SDNOD'=SDNAM
SET SDA(403.5,"D","MISMATCH",+SDI,SDNAM,SDNOD)=""
QUIT
End DoDot:2
End DoDot:1
+49 IF '$DATA(SDA(403.5,"D"))
WRITE !," No issues found."
+50 IF $DATA(SDA(403.5,"D"))
WRITE !," See summary below."
+51 ;AD xref in file 123 REQUEST/CONSULTATION ICR 6185
+52 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+53 WRITE !!,"BEGIN existing cross-reference validity checks for AD xref of file 123."
+54 WRITE !,Y
+55 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^GMR(123,"AD",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+56 SET SDDT=""
FOR
SET SDDT=$ORDER(^GMR(123,"AD",SDNAM,SDDT))
if SDDT=""
QUIT
Begin DoDot:2
+57 SET SDI=""
FOR
SET SDI=$ORDER(^GMR(123,"AD",SDNAM,SDDT,SDI))
if SDI=""
QUIT
Begin DoDot:3
+58 IF '$DATA(^GMR(123,+SDI,0))
SET SDA(123,"AD","INVALID",SDI,SDNAM)=""
QUIT
+59 SET SDNOD1=$$GET1^DIQ(123,+SDI_",",.02,"I")
+60 IF SDNOD1=""
SET SDA(123,"AD","MISMATCH",+SDI,SDNAM,"<no patient>")=""
QUIT
+61 IF SDNOD1'=SDNAM
SET SDA(123,"AD","MISMATCH",+SDI,SDNAM,SDNOD1)=""
QUIT
+62 SET SDNOD2=$$GET1^DIQ(123,+SDI_",",3,"I")
+63 IF SDNOD2=""
SET SDA(123,"AD","MISMATCH",+SDI,SDDT,"<no date of request>")=""
QUIT
+64 SET SDNOD2=9999999-SDNOD2
+65 IF SDNOD2'=SDDT
SET SDA(123,"AD","MISMATCH",+SDI,SDDT,SDNOD2)=""
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+66 IF '$DATA(SDA(123,"AD"))
WRITE !," No issues found."
+67 IF $DATA(SDA(123,"AB"))
WRITE !," See summary below."
+68 ;E xref in file 123 REQUEST/CONSULTATION ICR 6185
+69 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+70 WRITE !!,"BEGIN existing cross-reference validity checks for E xref of file 123."
+71 WRITE !,Y
+72 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^GMR(123,"E",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+73 SET SDI=""
FOR
SET SDI=$ORDER(^GMR(123,"E",SDNAM,SDI))
if SDI=""
QUIT
Begin DoDot:2
+74 IF '$DATA(^GMR(123,+SDI,0))
SET SDA(123,"E","INVALID",SDI,SDNAM)=""
QUIT
+75 SET SDNOD=$$GET1^DIQ(123,+SDI_",",3,"I")
+76 IF SDNOD=""
SET SDA(123,"E","MISMATCH",+SDI,SDNAM,"<no patient>")=""
QUIT
+77 IF SDNOD'=SDNAM
SET SDA(123,"E","MISMATCH",+SDI,SDNAM,SDNOD)=""
QUIT
End DoDot:2
End DoDot:1
+78 IF '$DATA(SDA(123,"E"))
WRITE !," No issues found."
+79 IF $DATA(SDA(123,"E"))
WRITE !," See summary below."
+80 ;AB xref in file 200 NEW PERSON
+81 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+82 WRITE !!,"BEGIN existing cross-reference validity checks for AB xref of file 200."
+83 WRITE !,Y
+84 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^VA(200,"AB",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+85 SET SDDT=""
FOR
SET SDDT=$ORDER(^VA(200,"AB",SDNAM,SDDT))
if SDDT=""
QUIT
Begin DoDot:2
+86 SET SDI=""
FOR
SET SDI=$ORDER(^VA(200,"AB",SDNAM,SDDT,SDI))
if SDI=""
QUIT
Begin DoDot:3
+87 ;SDDT=id to 200; SDNAM=id to key
IF '$DATA(^VA(200,+SDDT,51,SDI,0))
SET SDA(200,"AB","INVALID",SDDT,SDNAM)=""
End DoDot:3
End DoDot:2
End DoDot:1
+88 IF '$DATA(SDA(200,"AB"))
WRITE !," No issues found."
+89 IF $DATA(SDA(200,"AB"))
WRITE !," See summary below."
+90 ;B xref in file 200 NEW PERSON
+91 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+92 WRITE !!,"BEGIN existing cross-reference validity checks for B xref of file 200."
+93 WRITE !,Y
+94 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^VA(200,"B",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+95 SET SDI=""
FOR
SET SDI=$ORDER(^VA(200,"B",SDNAM,SDI))
if SDI=""
QUIT
Begin DoDot:2
+96 IF '$DATA(^VA(200,+SDI,0))
SET SDA(200,"B","INVALID",SDI,SDNAM)=""
QUIT
+97 SET SDNOD=$EXTRACT($$GET1^DIQ(200,+SDI_",",.01,"I"),1,30)
+98 IF SDNOD=""
SET SDA(200,"B","MISMATCH",+SDI,SDNAM,"<no new person>")=""
QUIT
+99 IF $EXTRACT(SDNOD,1,30)'=$EXTRACT(SDNAM,1,30)
SET SDA(200,"B","MISMATCH",+SDI,SDNAM,SDNOD)=""
QUIT
End DoDot:2
End DoDot:1
+100 IF '$DATA(SDA(200,"B"))
WRITE !," No issues found."
+101 IF $DATA(SDA(200,"B"))
WRITE !," See summary below."
+102 DO CHKW(.SDA)
+103 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+104 WRITE !!,Y
+105 WRITE !,"END existing cross-reference validity checks.",!!
+106 QUIT
CHKW(SDA) ;
+1 NEW SDF,SDI,SDNAM,SDNOD,SDS
+2 NEW T1,T2,T3
+3 if '$ORDER(SDA(0))
QUIT
+4 WRITE !!," SUMMARY of existing cross-reference validity checks:"
+5 WRITE !," ----------------------------------------------------"
+6 ;set tabs
+7 SET T1=2
SET T2=14
SET T3=46
+8 SET SDF=""
FOR
SET SDF=$ORDER(SDA(SDF))
if SDF=""
QUIT
Begin DoDot:1
+9 SET SDS=""
FOR
SET SDS=$ORDER(SDA(SDF,SDS))
if SDS=""
QUIT
Begin DoDot:2
+10 ;Invalid pointers
+11 IF $DATA(SDA(SDF,SDS,"INVALID"))>1
Begin DoDot:3
+12 WRITE !!,"INVALID POINTERS found in "_SDS_" xref of file "_SDF
+13 WRITE !,?T1,"ID",?T2,"XREF NAME"
+14 WRITE !,?T1,"--",?T2,"---------"
+15 SET SDI=""
FOR
SET SDI=$ORDER(SDA(SDF,SDS,"INVALID",SDI))
if SDI=""
QUIT
Begin DoDot:4
+16 SET SDNAM=""
FOR
SET SDNAM=$ORDER(SDA(SDF,SDS,"INVALID",SDI,SDNAM))
if SDNAM=""
QUIT
Begin DoDot:5
+17 WRITE !,?T1,SDI,?T2,SDNAM
End DoDot:5
End DoDot:4
End DoDot:3
+18 IF $DATA(SDA(SDF,SDS,"MISMATCH"))>1
Begin DoDot:3
+19 WRITE !!,"NAMES DO NOT MATCH found in "_SDS_" xref of file "_SDF
+20 WRITE !,?T1,"ID",?T2,"XREF NAME",?T3,"ENTRY NAME"
+21 WRITE !,?T1,"--",?T2,"---------",?T3,"----------"
+22 SET SDI=""
FOR
SET SDI=$ORDER(SDA(SDF,SDS,"MISMATCH",SDI))
if SDI=""
QUIT
Begin DoDot:4
+23 SET SDNAM=""
FOR
SET SDNAM=$ORDER(SDA(SDF,SDS,"MISMATCH",SDI,SDNAM))
if SDNAM=""
QUIT
Begin DoDot:5
+24 SET SDNOD=""
FOR
SET SDNOD=$ORDER(SDA(SDF,SDS,"MISMATCH",SDI,SDNAM,SDNOD))
if SDNOD=""
QUIT
Begin DoDot:6
+25 WRITE !,?T1,SDI,?T2,SDNAM,?T3,SDNOD
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;I '$D(SDA) W !," No issues found."
+27 QUIT
