- 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 Jan 18, 2025@03:53:21 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