EHMAPPT1 ;ALB/WTC - EHRM APPOINTMENT MAINTENANCE; Jun 05, 2025@14:50:54
;;1.0;ELECTRONIC HEALTH MODERNIZATION;**13**;Apr 19, 2021;Build 27
;
;
Q ;
;
CNVTDCLN ;
;
; Cleanup converted appointments. Change status in #409.84 and in #2 to CNV (CONVERTED TO CERNER) then clean up downstream files.
;
N X I '$$CRNRSITE^VAFCCRNR($P($$SITE^VASITE(),U,3)) W !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",! R !,"Pre [RETURN] to continue",X:$G(DTIME,300) Q ;
;
N CONVDATE,SORT1,SORT2,SORT3,APPTDTTM,DFN,CLINIC,SDECAPPT,PTAPPT,SCAPPT,ENCNTR,RSLT,SDECIEN,IEN2,CLINFLTR,CLINICS,NONCOUNT ;
;
W !!,"*** This option marks all selected appointments CONVERTED and cancels associated downstream file entries. ***",! ;
I $$CONTINUE()'=1 Q ;
;
D CNVSELCT^EHMAPPT("CLEANUP",.CONVDATE,1,.CLINFLTR,.CLINICS,,.NONCOUNT) Q:CONVDATE="" Q:CLINFLTR="" Q:NONCOUNT="" ; Build list of converted appointments.
;
D CNVTDAPT^EHMAPPT("CLEANUP",CONVDATE,1,CLINFLTR,.CLINICS,,NONCOUNT,0,0,0) ; Build list of converted appointments.
;
; Scan sorted data in ^TMP($J)
;
S SORT1="" F S SORT1=$O(^TMP($J,SORT1)) Q:SORT1="" D ;
. S SORT2="" F S SORT2=$O(^TMP($J,SORT1,SORT2)) Q:SORT2="" D ;
.. S SORT3="" F S SORT3=$O(^TMP($J,SORT1,SORT2,SORT3)) Q:SORT3="" D ;
... S APPTDTTM=SORT1,DFN=$P(SORT2,U,2),CLINIC=$P(SORT3,U,2) ;
... ;
... S SDECAPPT=$G(^TMP($J,SORT1,SORT2,SORT3,409.84)),SDECIEN=$P(SDECAPPT,U,1),SDECAPPT=$P(SDECAPPT,U,2,999) ;
... S PTAPPT=$G(^TMP($J,SORT1,SORT2,SORT3,2)),ENCNTR=$P(PTAPPT,U,20) ;
... S SCAPPT=$G(^TMP($J,SORT1,SORT2,SORT3,44)) ;
... ;
... ; Add appointment to #409.84 if missing.
... ;
... I 'SDECIEN D Q:'SDECIEN ;
.... ;
.... S IEN2=$P(SCAPPT,U,1) ;
.... S SDECIEN=$$ADDAPPT^EHM13UTIL(CLINIC,APPTDTTM,DFN,IEN2) ;
.... I 'SDECIEN W !,$$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$P(SORT2,U,1),?48,$P(SORT3,U,1)," cannot be automatically converted. Database entry - file #409.84 - not defined.",! ;
... ;
... ; Do not mark appointment converted if it has an ACTION REQUIRED encounter that is not empty.
... ;
... I ENCNTR'="",$$ENCTRSTS^EHM13UTIL(ENCNTR)="ACTION REQUIRED",'$$MPTYNCTR^EHM13UTIL(ENCNTR) D Q ;
.... W !,$$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$P(SORT2,U,1),?48,$P(SORT3,U,1)," cannot be automatically converted. Appointment has ACTION REQUIRED encounter.",! ;
... ;
... ; Mark appointment converted.
... ;
... S RSLT=$$APPDEL^EHMSDEC8(SDECIEN,"CNV","CONVERTED TO CERNER") ;
... W $$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$P(SORT2,U,1),"...",$S(RSLT:"OK",1:$P(RSLT,U,2)),! ;
;
K ^TMP($J) ;
Q ;
;
SELCTAPPT(ADDFLAG) ;
;
; Select appointment.
;
; ADDFLAG = 1 if appointment added to #409.84 if not defined, 0 if not (default = 0)
;
N SCIEN,DFN,APPTDATE,SDECIEN,DIC,X,Y,DIR,APPTDTTM,IEN2,COUNT,N,DIRUT,ENCNTR,ENCTRSTS ;
;
K DIC S DIC(0)="AEQM",DIC("S")="I $P(^(0),U,3)=""C""",DIC=44 D ^DIC Q:Y<0 0 S SCIEN=+Y ;
K DIC S DIC(0)="AEQM",DIC=2 D ^DIC Q:Y<0 0 S DFN=+Y ;
K DIR S DIR(0)="D^::EX",DIR("A")="Appointment Date" D ^DIR Q:Y<0 0 Q:$D(DIRUT) 0 S APPTDATE=Y ;
;
S APPTDTTM=APPTDATE,SDECIEN=0,COUNT=0 K ^TMP($J) W !!?5,"Appointment Date/Time",?30,"Encounter Status",!,?5,$$DASHES^EHM13UTIL(21),?30,$$DASHES^EHM13UTIL(30),! ;
F S APPTDTTM=$O(^SC(SCIEN,"S",APPTDTTM)) Q:'APPTDTTM Q:APPTDTTM\1'=APPTDATE D ;
. S IEN2=0 F S IEN2=$O(^SC(SCIEN,"S",APPTDTTM,1,IEN2)) Q:'IEN2 S X=$G(^(IEN2,0)) I $P(X,U,1)=DFN,$P(X,U,9)="" D ;
.. S ENCNTR=$P($G(^DPT(DFN,"S",APPTDTTM,0)),U,20),ENCTRSTS="" ;
.. I ENCNTR'="" S ENCTRSTS=$$ENCTRSTS^EHM13UTIL(ENCNTR) I ENCTRSTS="ACTION REQUIRED",$$MPTYNCTR^EHM13UTIL(ENCNTR) S ENCTRSTS="" ;
.. I ENCTRSTS'="ACTION REQUIRED" S COUNT=COUNT+1,^TMP($J,COUNT)=SCIEN_U_DFN_U_APPTDTTM_U_ENCNTR_U_IEN2 W $J(COUNT,2),".",?5,$$FMTE^XLFDT(APPTDTTM),?30,ENCTRSTS,! ;
.. E W ?5,$$FMTE^XLFDT(APPTDTTM),?30,ENCTRSTS,! ;
;
I 'COUNT W !,"No eligible appointments on file on ",$$FMTE^XLFDT(APPTDATE)," for ",$$GET1^DIQ(2,DFN,.01),!,"in the ",$$GET1^DIQ(44,SCIEN,.01)," clinic." K ^TMP($J) Q 0 ;
;
K DIR S DIR(0)="N^1:"_COUNT,DIR("A")="Select Appointment" D ^DIR Q:$D(DIRUT) 0 S N=Y ;
;
S DFN=$P(^TMP($J,N),U,2),APPTDTTM=$P(^(N),U,3),IEN2=$P(^(N),U,5) ;
K ^TMP($J) ;
;
S SDECIEN=0 F S SDECIEN=$O(^SDEC(409.84,"B",APPTDTTM,SDECIEN)) Q:'SDECIEN I $P(^SDEC(409.84,SDECIEN,0),U,5)=DFN,$P(^(0),U,12)="" Q ;
;
I 'ADDFLAG Q SDECIEN ;
I 'SDECIEN S SDECIEN=$$ADDAPPT^EHM13UTIL(SCIEN,APPTDTTM,DFN,IEN2) I 'SDECIEN W !,"Add appointment for file #409.84 failed" ; Add missing entry to file #409.84
;
Q SDECIEN ;
;
MARKCNVTD ;
;
; Select and mark an appointment converted.
;
N X I '$$CRNRSITE^VAFCCRNR($P($$SITE^VASITE(),U,3)) W !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",! R !,"Press [RETURN] to continue",X:$G(DTIME,300) Q ;
;
N SDECIEN,RSLT ;
W @IOF,$$CENTER^EHM13UTIL("Mark appointment converted",IOM),! ;
S SDECIEN=$$SELCTAPPT(1) Q:'SDECIEN ;
S RSLT=$$APPDEL^EHMSDEC8(SDECIEN,"CNV","CONVERTED TO CERNER") ;
I RSLT W !,"MARKED CONVERTED",! Q ;
W "FAILED. ERROR MESSAGE: ",$P(RSLT,U,2),! ;
Q ;
;
MARKCANC ;
;
; Select and mark an appointment cancelled - duplicate.
;
N X I '$$CRNRSITE^VAFCCRNR($P($$SITE^VASITE(),U,3)) W !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",! R !,"Press [RETURN] to continue",X:$G(DTIME,300) Q ;
;
N SDECIEN,RSLT ;
W @IOF,$$CENTER^EHM13UTIL("Mark appointment cancelled - duplicate",IOM),! ;
S SDECIEN=$$SELCTAPPT(1) Q:'SDECIEN ;
S RSLT=$$APPDEL^EHMSDEC8(SDECIEN,"C","DUPLICATE - CERNER") ;
I RSLT W !,"MARKED CANCELLED",! Q ;
W "FAILED. ERROR MESSAGE: ",$P(RSLT,U,2),! ;
Q ;
;
CANCAPPT ;
;
; Cancel appointments entered post go-live.
;
N X I '$$CRNRSITE^VAFCCRNR($P($$SITE^VASITE(),U,3)) W !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",! R !,"Press [RETURN] to continue",X:$G(DTIME,300) Q ;
;
W !!,"*** This option CANCELS all of the selected appointments and associated downstream file entries. ***",! ;
I $$CONTINUE()'=1 Q ;
;
N CONVDATE,DIRUT,SORT1,SORT2,SORT3,APPTDTTM,DFN,CLINIC,SDECAPPT,PTAPPT,SCAPPT,ENCNTR,RSLT,SDECIEN,CLINFLTR,CLINICS,NONCOUNT ;
;
D POSTSLCT^EHMAPPT0("CLEANUP",.CONVDATE,1,.CLINFLTR,.CLINICS,,.NONCOUNT) Q:CONVDATE="" Q:CLINFLTR="" Q:NONCOUNT="" ;
D POSTLIVE^EHMAPPT0("CLEANUP",CONVDATE,1,CLINFLTR,.CLINICS,,NONCOUNT,0,0,0) ; Build list of post-conversion appointments.
;
; Scan sorted data in ^TMP($J)
;
S SORT1="" F S SORT1=$O(^TMP($J,SORT1)) Q:SORT1="" D ;
. S SORT2="" F S SORT2=$O(^TMP($J,SORT1,SORT2)) Q:SORT2="" D ;
.. S SORT3="" F S SORT3=$O(^TMP($J,SORT1,SORT2,SORT3)) Q:SORT3="" D ;
... S APPTDTTM=SORT1,DFN=$P(SORT2,U,2),CLINIC=$P(SORT3,U,2) ;
... ;
... I $D(^EHRM(1610,"B",CLINIC)) Q ; Skip appointment in clinic that is active post go-live.
... ;
... S SDECAPPT=$G(^TMP($J,SORT1,SORT2,SORT3,409.84)),SDECIEN=$P(SDECAPPT,U,1),SDECAPPT=$P(SDECAPPT,U,2,999) ;
... S PTAPPT=$G(^TMP($J,SORT1,SORT2,SORT3,2)),ENCNTR=$P(PTAPPT,U,20) ;
... S SCAPPT=$G(^TMP($J,SORT1,SORT2,SORT3,44)) ;
... ;
... ; Add appointment to #409.84 if missing.
... ;
... I 'SDECIEN D Q:'SDECIEN ;
.... ;
.... S IEN2=$P(SCAPPT,U,1) ;
.... S SDECIEN=$$ADDAPPT^EHM13UTIL(CLINIC,APPTDTTM,DFN,IEN2) ;
.... I 'SDECIEN W !,$$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$P(SORT2,U,1),?48,$P(SORT3,U,1)," cannot be automatically cancelled. Database entry - file #409.84 - not defined.",! ;
... ;
... ; Do not mark cancel appointment if it has an ACTION REQUIRED encounter that is not empty.
... ;
... I ENCNTR'="",$$ENCTRSTS^EHM13UTIL(ENCNTR)="ACTION REQUIRED",'$$MPTYNCTR^EHM13UTIL(ENCNTR) D Q ;
.... W !,$$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$P(SORT2,U,1),?48,$P(SORT3,U,1)," cannot be automatically cancelled. Appointment has ACTION REQUIRED encounter.",! ;
... ;
... ; Cancel appointment.
... ;
... S RSLT=$$APPDEL^EHMSDEC8(SDECIEN,"C","DUPLICATE - CERNER") ;
... W $$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$P(SORT2,U,1),"...",$S(RSLT:"OK",1:$P(RSLT,U,2)),! ;
;
K ^TMP($J) ;
Q ;
;
INACTLIST ;
;
; List clinics and their eligibility to be inactivated.
;
N %DT,CONVDATE,Y,DIR,RPTFLTR,CLINIC,SCIEN,APPTCNT,SDDATE,IEN2,APPTDTTM,DIRUT,LINES,QUIT,POP,QUEUED,%ZIS,COUNT ;
;
S DIR(0)="S^1:All Clinics;2:All except Inactive Clinics;3:Clinics Eligible for Inactivation;4:Clinics with Future Appointments;",DIR("A")="Report Filter",DIR("B")=1 D ^DIR Q:Y="" Q:$D(DIRUT) S RPTFLTR=Y ;
;
S %ZIS="Q" D ^%ZIS I POP Q ;
;
; If report is queued, add to Taskman
;
S QUEUED=0 ;
I $D(IO("Q")) S QUEUED=1 D Q ;
. N ZTDESC,ZTRTN,ZTSAVE,ZTSK ;
. S ZTRTN="INACTLS1^EHMAPPT1",ZTDESC="Clinic Inactivation List" ;
. S ZTSAVE("*")="" ;
. D ^%ZTLOAD W $S($D(ZTSK):"...Task queued",1:"...Task cancelled"),! ;
;
INACTLS1 ; TaskMan start point
;
S TITLE=$P("All Clinics^All except Inactive Clinics^Clinics Eligible for Inactivation^Clinics with Future Appointments",U,RPTFLTR) ;
U IO D INACTHDR("Clinic Inactivation List: "_TITLE) ;
S LINES=0,QUIT=0 ;
;
S CLINIC="",COUNT("ELIGIBLE")=0,COUNT("INACTIVE")=0,COUNT("ACTIVE POST")=0,COUNT("APPOINTMENTS")=0 ;
F S CLINIC=$O(^SC("B",CLINIC)) Q:CLINIC="" D Q:QUIT ;
. S SCIEN=0 F S SCIEN=$O(^SC("B",CLINIC,SCIEN)) Q:'SCIEN I $P($G(^SC(SCIEN,0)),U,3)="C" D Q:QUIT ; Exclude locations that aren't clinics. wtc 5/1/24
.. ;
.. ; If report displayed on screen, stop when screen full and prompt user to continue or stop.
.. ;
.. I 'QUEUED D Q:QUIT ;
... U 0 ;
... I IO=$I Q:LINES<(IOSL-7) S QUIT=$$CONTINUE^EHM13UTIL()=0 Q:QUIT U IO D INACTHDR("Clinic Inactivation List: "_TITLE) S LINES=1 Q ;
... ;
... ; New page header for printed report
... ;
... I LINES'<IOSL U IO D INACTHDR("Clinic Inactivation List: "_TITLE) S LINES=1 ;
.. ;
.. U IO ;
.. I $D(^EHRM(1610,"B",SCIEN)) Q:RPTFLTR'=1&(RPTFLTR'=2) W CLINIC,?32,"ACTIVE POST GO-LIVE",! S LINES=LINES+1,COUNT("ACTIVE POST")=COUNT("ACTIVE POST")+1 Q ;
.. I $D(^SC(SCIEN,"I")),+^("I")'=0,+^("I")'>DT,+$P(^("I"),"^",2)'>0 Q:RPTFLTR'=1 W CLINIC,?32,"INACTIVE",! S LINES=LINES+1,COUNT("INACTIVE")=COUNT("INACTIVE")+1 Q ;
.. ;
.. S APPTCNT=$$APPTCNT(SCIEN) ;
.. I APPTCNT>0 Q:RPTFLTR=3 W CLINIC,?32,"CANNOT BE INACTIVATED. ",APPTCNT," APPOINTMENT",$S(APPTCNT>1:"S",1:"")," PRESENT.",! S LINES=LINES+1,COUNT("APPOINTMENTS")=COUNT("APPOINTMENTS")+1 Q ;
.. Q:RPTFLTR=4 W CLINIC,?32,"ELIGIBLE FOR INACTIVATION",! S LINES=LINES+1,COUNT("ELIGIBLE")=COUNT("ELIGIBLE")+1 ;
;
W ! ;
I RPTFLTR'=4 W "Clinics eligible for inactivation: ",COUNT("ELIGIBLE"),! ;
I RPTFLTR'=3 W "Clinics with active appointments: ",COUNT("APPOINTMENTS"),! ;
I RPTFLTR=1 W "Inactive clinics: ",COUNT("INACTIVE"),! ;
I RPTFLTR=1!(RPTFLTR=2) W "Clinics active post go-live: ",COUNT("ACTIVE POST"),!
;
U 0 I 'QUEUED,IO=$I R !,"Press [RETURN] to continue",X:$G(DTIME,300) ;
;
D ^%ZISC ;
Q ;
;
APPTCNT(SCIEN) ;
;
; Returns number of active current and future appointments for a clinic.
;
N APPTCNT,APPTDTTM,IEN2 ;
;
S APPTCNT=0,APPTDTTM=DT-.0001 F S APPTDTTM=$O(^SC(SCIEN,"S",APPTDTTM)) Q:'APPTDTTM D ;
. S IEN2=0 F S IEN2=$O(^SC(SCIEN,"S",APPTDTTM,1,IEN2)) Q:'IEN2 I $P(^(IEN2,0),"^",9)'="C",$$GET1^DIQ(44.003,IEN2_","_APPTDTTM_","_SCIEN,5)'="CONVERTED TO CERNER" S APPTCNT=APPTCNT+1 ;
;
Q APPTCNT ;
;
INACTHDR(TITLE) ;
;
W @IOF,$$CENTER^EHM13UTIL(TITLE,IOM),! ;
W !,"CLINIC",?32,"STATUS",!,$$DASHES^EHM13UTIL(30),?32,$$DASHES^EHM13UTIL(45),! ;
Q ;
;
INACTVAT ;
;
; Scan clinics and inactivate them.
;
N X I '$$CRNRSITE^VAFCCRNR($P($$SITE^VASITE(),U,3)) W !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",! R !,"Press [RETURN] to continue",X:$G(DTIME,300) Q ;
;
N %DT,Y,I,SCIEN,CONVDATE,RTNCODE,DIQUIET,COUNT,CLINNAME ;
;
K ^TMP($J) S DIQUIET=1 ;
;
; Enter date of conversion.
;
K %DT S %DT="A",%DT("A")="DATE OF CONVERSION: " D ^%DT Q:Y<0 S CONVDATE=+Y ;
;
W !!,"*** This option INACTIVATES all eligible clinics. ***",! ;
I $$CONTINUE()'=1 Q ;
;
; Scan clinics
;
S COUNT("INACTIVATED")=0,COUNT("FAILED")=0,COUNT("FAILED","Inactive")=0,COUNT("FAILED","Future appointments")=0 ;
;
W !,"Inactivating clinics..." ;
S SCIEN=0 F I=1:1 S SCIEN=$O(^SC(SCIEN)) Q:'SCIEN W:I#100=0 "." I $$GET1^DIQ(44,SCIEN,2)="CLINIC" D ;
. ;
. I $D(^EHRM(1610,"B",SCIEN)) Q ; Skip clinic that is open post go-live.
. ;
. I $D(^SC(SCIEN,"I")),+^("I")'=0,+^("I")'>DT,+$P(^("I"),"^",2)'>0 Q ; Skip already inactive clinic
. ;
. S RTNCODE=$$SDNACT(SCIEN,CONVDATE) ;
. I RTNCODE S ^TMP($J,$$GET1^DIQ(44,SCIEN,.01),SCIEN)="INACTIVATED",COUNT("INACTIVATED")=COUNT("INACTIVATED")+1 Q ;
. S ^TMP($J,$$GET1^DIQ(44,SCIEN,.01),SCIEN)="INACTIVATION FAILED: "_$P(RTNCODE,U,2) ;
. S COUNT("FAILED")=COUNT("FAILED")+1,COUNT("FAILED",$P(RTNCODE,U,2))=COUNT("FAILED",$P(RTNCODE,U,2))+1 Q ;
;
W !!,"CLINIC",?32,"STATUS",?46,"REASON",! ;
W $$DASHES^EHM13UTIL(30),?32,$$DASHES^EHM13UTIL(11),?46,$$DASHES^EHM13UTIL(30),! ;
S CLINNAME="" F S CLINNAME=$O(^TMP($J,CLINNAME)) Q:CLINNAME="" S SCIEN=0 F S SCIEN=$O(^TMP($J,CLINNAME,SCIEN)) Q:'SCIEN S X=^(SCIEN) D ;
. ;
. I X["INACTIVATED" W CLINNAME,?32,"INACTIVATED",! Q ;
. W CLINNAME,?32,"FAILED",?46,$P(X,": ",2),! ;
;
W ! ;
W "CLINICS INACTIVATED: ",COUNT("INACTIVATED"),! ;
W "INACTIVATION FAILED: ",COUNT("FAILED"),! ;
W ?5,"Future appointments: ",COUNT("FAILED","Future appointments"),! ;
;
K ^TMP($J) ;
Q ;
;
SDNACT(SC,SDDATE) ;ALB/TMP - INACTIVATE A CLINIC ;Mar 25, 2021@15:05:56
;
; SC = IEN of clinic in file #44
; SDDATE = Conversion date
;
; Returns 1 if inactivated or 0^error messaage if not.
;
; Cloned from SDNACT.
;
N ERRMSG,A,DA,CNT,D0,DH,DO,DOW,I,I1,J,J1,POP,SD,SD0,SDAY,SDEL,SDFSW,SDN,SDNL,SDOL,SDREACT,SI,SL,STARTDAY,SDX,SDX1,SDZQ,X,X1,X2,Y,Z,DIE,DR,DIC ;
;
S ERRMSG="" ;
;
S SDAY="Sun^Mon^Tues^Wednes^Thurs^Fri^Satur",SDZQ=1
D DT^DICRW ;
;
S SDX="",SDX1=9999999 ;
;
D ;
;S POP=0 F I=SDDATE-.0001:0 S I=$O(^SC(SC,"S",I)) Q:'I!(POP)!(SDDATE'<SDX1&(SDX1)) F I1=0:0 S I1=$O(^SC(SC,"S",I,1,I1)) Q:'I1 I $P(^(I1,0),"^",9)'="C",$$GET1^DIQ(44.003,I1_","_I_","_SC,5)="CONVERTED TO CERNER" S POP=1 Q
S POP=$$APPTCNT(SC) ;
I POP S ERRMSG="Future appointments" G END ;
I SDX'="" D CHG1 G OVR
K SDN S ^SC(SC,"I")="",X=SDDATE D DOW^SDM0 S SDN(Y)=SDDATE F I=1:1:6 S X2=1,X1=X D C^%DTC,DOW^SDM0 S SDN(Y)=X
F I=0:1:6 S J=$O(^SC(SC,"T"_I,SDN(I))) D GOT
OVR F I=SDDATE-.0001:0 S I=$O(^SC(SC,"ST",I)) Q:'I!(I>SDX1) K ^(I)
F I=SDDATE-.0001:0 S I=$O(^SC(SC,"T",I)) Q:'I!(I>SDX1) K ^(I)
F I=SDDATE-.0001:0 S I=$O(^SC(SC,"OST",I)) Q:'I!(I>SDX1) K ^(I)
S DIE="^SC(",DA=SC,DR="2505///^S X=SDDATE;2506///" D ^DIE ; Set inactive date and clear reactive date. wtc 10.10.23
D SDEC^SDNACT(SC,SDDATE) ;alb/sat 627
G END ;
;
CHECK ;
;
DEL ;
;
CHG1 ;;wtc ;K SDN S X1=SDDATE,X2=6 D C^%DTC S SDNL=X,X=SDDATE D DOW^SDM0 S SDN(Y)=X
F I=1:1:6 S X1=X,X2=1 D C^%DTC,DOW^SDM0 S SDN(Y)=X
S X1=SDX,X2=6 D C^%DTC S SDOL=X,X1=SDX,X2=-1 D C^%DTC
F I=0:0 S X2=1,X1=X D C^%DTC Q:X>SDOL D DOW^SDM0 S:$D(^SC(SC,"T"_Y))&($O(^SC(SC,"T"_Y,0))'=9999999) ^SC(SC,"T"_Y,SDN(Y),1)=$S($D(^SC(SC,"T"_Y,X,1)):^(1),1:""),^(0)=SDN(Y) D A1,A
I SDDATE<SDX F I=0:1:6 F J=SDNL:0 S J=$O(^SC(SC,"T"_I,J)) Q:'J!(J'<SDX) K ^SC(SC,"T"_I,J)
Q
A1 S:'$D(^SC(SC,"T"_Y,9999999,1)) ^(1)="",^(0)=9999999 K:(SDN(Y)-X) ^SC(SC,"T"_Y,X)
Q
A I $O(^SC(SC,"T"_Y,SDN(Y)))>0 S SD=$O(^SC(SC,"T"_Y,SDN(Y))) S:^SC(SC,"T"_Y,SD,1)]"" ^SC(SC,"T"_Y,SDN(Y),1)=^SC(SC,"T"_Y,SD,1),^(0)=SDN(Y),^SC(SC,"T"_Y,SD,1)=""
I SDX'>SDDATE,$O(^SC(SC,"ST",SDX-.1))>0 F Z=SDX-.1:0 S Z=$O(^SC(SC,"ST",Z)) Q:'Z!(SDX1&(Z'<SDX1)) K ^SC(SC,"ST",Z)
K SD,Z Q
GOT S SD=$O(^SC(SC,"T"_I,0))
I J>0,SD'=9999999,^SC(SC,"T"_I,J,1)'="" S ^SC(SC,"T"_I,SDN(I),1)=^SC(SC,"T"_I,J,1),^(0)=SDN(I) K ^SC(SC,"T"_I,J) F J1=J:0 S J1=$O(^SC(SC,"T"_I,J1)) Q:'J1 K ^SC(SC,"T"_I,J1) ;don't remove if already canceled, SD*5.3*726
S ^SC(SC,"T"_I,9999999,1)="",^(0)=9999999
Q
END ;
I $G(ERRMSG)="" Q 1 ;
Q 0_U_ERRMSG ;
;
CONTINUE() ;
;
; Prompt user to continue or quit.
;
N DIR,Y,DIRUT ;
S DIR(0)="Y",DIR("A")="Are you sure?",DIR("B")="NO" D ^DIR ;
I $D(DIRUT) Q 0 ;
Q Y ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEHMAPPT1 16296 printed Apr 22, 2026@13:48:18 Page 2
EHMAPPT1 ;ALB/WTC - EHRM APPOINTMENT MAINTENANCE; Jun 05, 2025@14:50:54
+1 ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**13**;Apr 19, 2021;Build 27
+2 ;
+3 ;
+4 ;
QUIT
+5 ;
CNVTDCLN ;
+1 ;
+2 ; Cleanup converted appointments. Change status in #409.84 and in #2 to CNV (CONVERTED TO CERNER) then clean up downstream files.
+3 ;
+4 ;
NEW X
IF '$$CRNRSITE^VAFCCRNR($PIECE($$SITE^VASITE(),U,3))
WRITE !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",!
READ !,"Pre [RETURN] to continue",X:$GET(DTIME,300)
QUIT
+5 ;
+6 ;
NEW CONVDATE,SORT1,SORT2,SORT3,APPTDTTM,DFN,CLINIC,SDECAPPT,PTAPPT,SCAPPT,ENCNTR,RSLT,SDECIEN,IEN2,CLINFLTR,CLINICS,NONCOUNT
+7 ;
+8 ;
WRITE !!,"*** This option marks all selected appointments CONVERTED and cancels associated downstream file entries. ***",!
+9 ;
IF $$CONTINUE()'=1
QUIT
+10 ;
+11 ; Build list of converted appointments.
DO CNVSELCT^EHMAPPT("CLEANUP",.CONVDATE,1,.CLINFLTR,.CLINICS,,.NONCOUNT)
if CONVDATE=""
QUIT
if CLINFLTR=""
QUIT
if NONCOUNT=""
QUIT
+12 ;
+13 ; Build list of converted appointments.
DO CNVTDAPT^EHMAPPT("CLEANUP",CONVDATE,1,CLINFLTR,.CLINICS,,NONCOUNT,0,0,0)
+14 ;
+15 ; Scan sorted data in ^TMP($J)
+16 ;
+17 ;
SET SORT1=""
FOR
SET SORT1=$ORDER(^TMP($JOB,SORT1))
if SORT1=""
QUIT
Begin DoDot:1
+18 ;
SET SORT2=""
FOR
SET SORT2=$ORDER(^TMP($JOB,SORT1,SORT2))
if SORT2=""
QUIT
Begin DoDot:2
+19 ;
SET SORT3=""
FOR
SET SORT3=$ORDER(^TMP($JOB,SORT1,SORT2,SORT3))
if SORT3=""
QUIT
Begin DoDot:3
+20 ;
SET APPTDTTM=SORT1
SET DFN=$PIECE(SORT2,U,2)
SET CLINIC=$PIECE(SORT3,U,2)
+21 ;
+22 ;
SET SDECAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,409.84))
SET SDECIEN=$PIECE(SDECAPPT,U,1)
SET SDECAPPT=$PIECE(SDECAPPT,U,2,999)
+23 ;
SET PTAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,2))
SET ENCNTR=$PIECE(PTAPPT,U,20)
+24 ;
SET SCAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,44))
+25 ;
+26 ; Add appointment to #409.84 if missing.
+27 ;
+28 ;
IF 'SDECIEN
Begin DoDot:4
+29 ;
+30 ;
SET IEN2=$PIECE(SCAPPT,U,1)
+31 ;
SET SDECIEN=$$ADDAPPT^EHM13UTIL(CLINIC,APPTDTTM,DFN,IEN2)
+32 ;
IF 'SDECIEN
WRITE !,$$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$PIECE(SORT2,U,1),?48,$PIECE(SORT3,U,1)," cannot be automatically converted. Database entry - file #409.84 - not defined.",!
End DoDot:4
if 'SDECIEN
QUIT
+33 ;
+34 ; Do not mark appointment converted if it has an ACTION REQUIRED encounter that is not empty.
+35 ;
+36 ;
IF ENCNTR'=""
IF $$ENCTRSTS^EHM13UTIL(ENCNTR)="ACTION REQUIRED"
IF '$$MPTYNCTR^EHM13UTIL(ENCNTR)
Begin DoDot:4
+37 ;
WRITE !,$$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$PIECE(SORT2,U,1),?48,$PIECE(SORT3,U,1)," cannot be automatically converted. Appointment has ACTION REQUIRED encounter.",!
End DoDot:4
QUIT
+38 ;
+39 ; Mark appointment converted.
+40 ;
+41 ;
SET RSLT=$$APPDEL^EHMSDEC8(SDECIEN,"CNV","CONVERTED TO CERNER")
+42 ;
WRITE $$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$PIECE(SORT2,U,1),"...",$SELECT(RSLT:"OK",1:$PIECE(RSLT,U,2)),!
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;
+44 ;
KILL ^TMP($JOB)
+45 ;
QUIT
+46 ;
SELCTAPPT(ADDFLAG) ;
+1 ;
+2 ; Select appointment.
+3 ;
+4 ; ADDFLAG = 1 if appointment added to #409.84 if not defined, 0 if not (default = 0)
+5 ;
+6 ;
NEW SCIEN,DFN,APPTDATE,SDECIEN,DIC,X,Y,DIR,APPTDTTM,IEN2,COUNT,N,DIRUT,ENCNTR,ENCTRSTS
+7 ;
+8 ;
KILL DIC
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,3)=""C"""
SET DIC=44
DO ^DIC
if Y<0
QUIT 0
SET SCIEN=+Y
+9 ;
KILL DIC
SET DIC(0)="AEQM"
SET DIC=2
DO ^DIC
if Y<0
QUIT 0
SET DFN=+Y
+10 ;
KILL DIR
SET DIR(0)="D^::EX"
SET DIR("A")="Appointment Date"
DO ^DIR
if Y<0
QUIT 0
if $DATA(DIRUT)
QUIT 0
SET APPTDATE=Y
+11 ;
+12 ;
SET APPTDTTM=APPTDATE
SET SDECIEN=0
SET COUNT=0
KILL ^TMP($JOB)
WRITE !!?5,"Appointment Date/Time",?30,"Encounter Status",!,?5,$$DASHES^EHM13UTIL(21),?30,$$DASHES^EHM13UTIL(30),!
+13 ;
FOR
SET APPTDTTM=$ORDER(^SC(SCIEN,"S",APPTDTTM))
if 'APPTDTTM
QUIT
if APPTDTTM\1'=APPTDATE
QUIT
Begin DoDot:1
+14 ;
SET IEN2=0
FOR
SET IEN2=$ORDER(^SC(SCIEN,"S",APPTDTTM,1,IEN2))
if 'IEN2
QUIT
SET X=$GET(^(IEN2,0))
IF $PIECE(X,U,1)=DFN
IF $PIECE(X,U,9)=""
Begin DoDot:2
+15 ;
SET ENCNTR=$PIECE($GET(^DPT(DFN,"S",APPTDTTM,0)),U,20)
SET ENCTRSTS=""
+16 ;
IF ENCNTR'=""
SET ENCTRSTS=$$ENCTRSTS^EHM13UTIL(ENCNTR)
IF ENCTRSTS="ACTION REQUIRED"
IF $$MPTYNCTR^EHM13UTIL(ENCNTR)
SET ENCTRSTS=""
+17 ;
IF ENCTRSTS'="ACTION REQUIRED"
SET COUNT=COUNT+1
SET ^TMP($JOB,COUNT)=SCIEN_U_DFN_U_APPTDTTM_U_ENCNTR_U_IEN2
WRITE $JUSTIFY(COUNT,2),".",?5,$$FMTE^XLFDT(APPTDTTM),?30,ENCTRSTS,!
+18 ;
IF '$TEST
WRITE ?5,$$FMTE^XLFDT(APPTDTTM),?30,ENCTRSTS,!
End DoDot:2
End DoDot:1
+19 ;
+20 ;
IF 'COUNT
WRITE !,"No eligible appointments on file on ",$$FMTE^XLFDT(APPTDATE)," for ",$$GET1^DIQ(2,DFN,.01),!,"in the ",$$GET1^DIQ(44,SCIEN,.01)," clinic."
KILL ^TMP($JOB)
QUIT 0
+21 ;
+22 ;
KILL DIR
SET DIR(0)="N^1:"_COUNT
SET DIR("A")="Select Appointment"
DO ^DIR
if $DATA(DIRUT)
QUIT 0
SET N=Y
+23 ;
+24 ;
SET DFN=$PIECE(^TMP($JOB,N),U,2)
SET APPTDTTM=$PIECE(^(N),U,3)
SET IEN2=$PIECE(^(N),U,5)
+25 ;
KILL ^TMP($JOB)
+26 ;
+27 ;
SET SDECIEN=0
FOR
SET SDECIEN=$ORDER(^SDEC(409.84,"B",APPTDTTM,SDECIEN))
if 'SDECIEN
QUIT
IF $PIECE(^SDEC(409.84,SDECIEN,0),U,5)=DFN
IF $PIECE(^(0),U,12)=""
QUIT
+28 ;
+29 ;
IF 'ADDFLAG
QUIT SDECIEN
+30 ; Add missing entry to file #409.84
IF 'SDECIEN
SET SDECIEN=$$ADDAPPT^EHM13UTIL(SCIEN,APPTDTTM,DFN,IEN2)
IF 'SDECIEN
WRITE !,"Add appointment for file #409.84 failed"
+31 ;
+32 ;
QUIT SDECIEN
+33 ;
MARKCNVTD ;
+1 ;
+2 ; Select and mark an appointment converted.
+3 ;
+4 ;
NEW X
IF '$$CRNRSITE^VAFCCRNR($PIECE($$SITE^VASITE(),U,3))
WRITE !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",!
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
QUIT
+5 ;
+6 ;
NEW SDECIEN,RSLT
+7 ;
WRITE @IOF,$$CENTER^EHM13UTIL("Mark appointment converted",IOM),!
+8 ;
SET SDECIEN=$$SELCTAPPT(1)
if 'SDECIEN
QUIT
+9 ;
SET RSLT=$$APPDEL^EHMSDEC8(SDECIEN,"CNV","CONVERTED TO CERNER")
+10 ;
IF RSLT
WRITE !,"MARKED CONVERTED",!
QUIT
+11 ;
WRITE "FAILED. ERROR MESSAGE: ",$PIECE(RSLT,U,2),!
+12 ;
QUIT
+13 ;
MARKCANC ;
+1 ;
+2 ; Select and mark an appointment cancelled - duplicate.
+3 ;
+4 ;
NEW X
IF '$$CRNRSITE^VAFCCRNR($PIECE($$SITE^VASITE(),U,3))
WRITE !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",!
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
QUIT
+5 ;
+6 ;
NEW SDECIEN,RSLT
+7 ;
WRITE @IOF,$$CENTER^EHM13UTIL("Mark appointment cancelled - duplicate",IOM),!
+8 ;
SET SDECIEN=$$SELCTAPPT(1)
if 'SDECIEN
QUIT
+9 ;
SET RSLT=$$APPDEL^EHMSDEC8(SDECIEN,"C","DUPLICATE - CERNER")
+10 ;
IF RSLT
WRITE !,"MARKED CANCELLED",!
QUIT
+11 ;
WRITE "FAILED. ERROR MESSAGE: ",$PIECE(RSLT,U,2),!
+12 ;
QUIT
+13 ;
CANCAPPT ;
+1 ;
+2 ; Cancel appointments entered post go-live.
+3 ;
+4 ;
NEW X
IF '$$CRNRSITE^VAFCCRNR($PIECE($$SITE^VASITE(),U,3))
WRITE !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",!
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
QUIT
+5 ;
+6 ;
WRITE !!,"*** This option CANCELS all of the selected appointments and associated downstream file entries. ***",!
+7 ;
IF $$CONTINUE()'=1
QUIT
+8 ;
+9 ;
NEW CONVDATE,DIRUT,SORT1,SORT2,SORT3,APPTDTTM,DFN,CLINIC,SDECAPPT,PTAPPT,SCAPPT,ENCNTR,RSLT,SDECIEN,CLINFLTR,CLINICS,NONCOUNT
+10 ;
+11 ;
DO POSTSLCT^EHMAPPT0("CLEANUP",.CONVDATE,1,.CLINFLTR,.CLINICS,,.NONCOUNT)
if CONVDATE=""
QUIT
if CLINFLTR=""
QUIT
if NONCOUNT=""
QUIT
+12 ; Build list of post-conversion appointments.
DO POSTLIVE^EHMAPPT0("CLEANUP",CONVDATE,1,CLINFLTR,.CLINICS,,NONCOUNT,0,0,0)
+13 ;
+14 ; Scan sorted data in ^TMP($J)
+15 ;
+16 ;
SET SORT1=""
FOR
SET SORT1=$ORDER(^TMP($JOB,SORT1))
if SORT1=""
QUIT
Begin DoDot:1
+17 ;
SET SORT2=""
FOR
SET SORT2=$ORDER(^TMP($JOB,SORT1,SORT2))
if SORT2=""
QUIT
Begin DoDot:2
+18 ;
SET SORT3=""
FOR
SET SORT3=$ORDER(^TMP($JOB,SORT1,SORT2,SORT3))
if SORT3=""
QUIT
Begin DoDot:3
+19 ;
SET APPTDTTM=SORT1
SET DFN=$PIECE(SORT2,U,2)
SET CLINIC=$PIECE(SORT3,U,2)
+20 ;
+21 ; Skip appointment in clinic that is active post go-live.
IF $DATA(^EHRM(1610,"B",CLINIC))
QUIT
+22 ;
+23 ;
SET SDECAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,409.84))
SET SDECIEN=$PIECE(SDECAPPT,U,1)
SET SDECAPPT=$PIECE(SDECAPPT,U,2,999)
+24 ;
SET PTAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,2))
SET ENCNTR=$PIECE(PTAPPT,U,20)
+25 ;
SET SCAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,44))
+26 ;
+27 ; Add appointment to #409.84 if missing.
+28 ;
+29 ;
IF 'SDECIEN
Begin DoDot:4
+30 ;
+31 ;
SET IEN2=$PIECE(SCAPPT,U,1)
+32 ;
SET SDECIEN=$$ADDAPPT^EHM13UTIL(CLINIC,APPTDTTM,DFN,IEN2)
+33 ;
IF 'SDECIEN
WRITE !,$$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$PIECE(SORT2,U,1),?48,$PIECE(SORT3,U,1)," cannot be automatically cancelled. Database entry - file #409.84 - not defined.",!
End DoDot:4
if 'SDECIEN
QUIT
+34 ;
+35 ; Do not mark cancel appointment if it has an ACTION REQUIRED encounter that is not empty.
+36 ;
+37 ;
IF ENCNTR'=""
IF $$ENCTRSTS^EHM13UTIL(ENCNTR)="ACTION REQUIRED"
IF '$$MPTYNCTR^EHM13UTIL(ENCNTR)
Begin DoDot:4
+38 ;
WRITE !,$$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$PIECE(SORT2,U,1),?48,$PIECE(SORT3,U,1)," cannot be automatically cancelled. Appointment has ACTION REQUIRED encounter.",!
End DoDot:4
QUIT
+39 ;
+40 ; Cancel appointment.
+41 ;
+42 ;
SET RSLT=$$APPDEL^EHMSDEC8(SDECIEN,"C","DUPLICATE - CERNER")
+43 ;
WRITE $$FMTDTTM^EHM13UTIL(APPTDTTM),?16,$PIECE(SORT2,U,1),"...",$SELECT(RSLT:"OK",1:$PIECE(RSLT,U,2)),!
End DoDot:3
End DoDot:2
End DoDot:1
+44 ;
+45 ;
KILL ^TMP($JOB)
+46 ;
QUIT
+47 ;
INACTLIST ;
+1 ;
+2 ; List clinics and their eligibility to be inactivated.
+3 ;
+4 ;
NEW %DT,CONVDATE,Y,DIR,RPTFLTR,CLINIC,SCIEN,APPTCNT,SDDATE,IEN2,APPTDTTM,DIRUT,LINES,QUIT,POP,QUEUED,%ZIS,COUNT
+5 ;
+6 ;
SET DIR(0)="S^1:All Clinics;2:All except Inactive Clinics;3:Clinics Eligible for Inactivation;4:Clinics with Future Appointments;"
SET DIR("A")="Report Filter"
SET DIR("B")=1
DO ^DIR
if Y=""
QUIT
if $DATA(DIRUT)
QUIT
SET RPTFLTR=Y
+7 ;
+8 ;
SET %ZIS="Q"
DO ^%ZIS
IF POP
QUIT
+9 ;
+10 ; If report is queued, add to Taskman
+11 ;
+12 ;
SET QUEUED=0
+13 ;
IF $DATA(IO("Q"))
SET QUEUED=1
Begin DoDot:1
+14 ;
NEW ZTDESC,ZTRTN,ZTSAVE,ZTSK
+15 ;
SET ZTRTN="INACTLS1^EHMAPPT1"
SET ZTDESC="Clinic Inactivation List"
+16 ;
SET ZTSAVE("*")=""
+17 ;
DO ^%ZTLOAD
WRITE $SELECT($DATA(ZTSK):"...Task queued",1:"...Task cancelled"),!
End DoDot:1
QUIT
+18 ;
INACTLS1 ; TaskMan start point
+1 ;
+2 ;
SET TITLE=$PIECE("All Clinics^All except Inactive Clinics^Clinics Eligible for Inactivation^Clinics with Future Appointments",U,RPTFLTR)
+3 ;
USE IO
DO INACTHDR("Clinic Inactivation List: "_TITLE)
+4 ;
SET LINES=0
SET QUIT=0
+5 ;
+6 ;
SET CLINIC=""
SET COUNT("ELIGIBLE")=0
SET COUNT("INACTIVE")=0
SET COUNT("ACTIVE POST")=0
SET COUNT("APPOINTMENTS")=0
+7 ;
FOR
SET CLINIC=$ORDER(^SC("B",CLINIC))
if CLINIC=""
QUIT
Begin DoDot:1
+8 ; Exclude locations that aren't clinics. wtc 5/1/24
SET SCIEN=0
FOR
SET SCIEN=$ORDER(^SC("B",CLINIC,SCIEN))
if 'SCIEN
QUIT
IF $PIECE($GET(^SC(SCIEN,0)),U,3)="C"
Begin DoDot:2
+9 ;
+10 ; If report displayed on screen, stop when screen full and prompt user to continue or stop.
+11 ;
+12 ;
IF 'QUEUED
Begin DoDot:3
+13 ;
USE 0
+14 ;
IF IO=$IO
if LINES<(IOSL-7)
QUIT
SET QUIT=$$CONTINUE^EHM13UTIL()=0
if QUIT
QUIT
USE IO
DO INACTHDR("Clinic Inactivation List: "_TITLE)
SET LINES=1
QUIT
+15 ;
+16 ; New page header for printed report
+17 ;
+18 ;
IF LINES'<IOSL
USE IO
DO INACTHDR("Clinic Inactivation List: "_TITLE)
SET LINES=1
End DoDot:3
if QUIT
QUIT
+19 ;
+20 ;
USE IO
+21 ;
IF $DATA(^EHRM(1610,"B",SCIEN))
if RPTFLTR'=1&(RPTFLTR'=2)
QUIT
WRITE CLINIC,?32,"ACTIVE POST GO-LIVE",!
SET LINES=LINES+1
SET COUNT("ACTIVE POST")=COUNT("ACTIVE POST")+1
QUIT
+22 ;
IF $DATA(^SC(SCIEN,"I"))
IF +^("I")'=0
IF +^("I")'>DT
IF +$PIECE(^("I"),"^",2)'>0
if RPTFLTR'=1
QUIT
WRITE CLINIC,?32,"INACTIVE",!
SET LINES=LINES+1
SET COUNT("INACTIVE")=COUNT("INACTIVE")+1
QUIT
+23 ;
+24 ;
SET APPTCNT=$$APPTCNT(SCIEN)
+25 ;
IF APPTCNT>0
if RPTFLTR=3
QUIT
WRITE CLINIC,?32,"CANNOT BE INACTIVATED. ",APPTCNT," APPOINTMENT",$SELECT(APPTCNT>1:"S",1:"")," PRESENT.",!
SET LINES=LINES+1
SET COUNT("APPOINTMENTS")=COUNT("APPOINTMENTS")+1
QUIT
+26 ;
if RPTFLTR=4
QUIT
WRITE CLINIC,?32,"ELIGIBLE FOR INACTIVATION",!
SET LINES=LINES+1
SET COUNT("ELIGIBLE")=COUNT("ELIGIBLE")+1
End DoDot:2
if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+27 ;
+28 ;
WRITE !
+29 ;
IF RPTFLTR'=4
WRITE "Clinics eligible for inactivation: ",COUNT("ELIGIBLE"),!
+30 ;
IF RPTFLTR'=3
WRITE "Clinics with active appointments: ",COUNT("APPOINTMENTS"),!
+31 ;
IF RPTFLTR=1
WRITE "Inactive clinics: ",COUNT("INACTIVE"),!
+32 IF RPTFLTR=1!(RPTFLTR=2)
WRITE "Clinics active post go-live: ",COUNT("ACTIVE POST"),!
+33 ;
+34 ;
USE 0
IF 'QUEUED
IF IO=$IO
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
+35 ;
+36 ;
DO ^%ZISC
+37 ;
QUIT
+38 ;
APPTCNT(SCIEN) ;
+1 ;
+2 ; Returns number of active current and future appointments for a clinic.
+3 ;
+4 ;
NEW APPTCNT,APPTDTTM,IEN2
+5 ;
+6 ;
SET APPTCNT=0
SET APPTDTTM=DT-.0001
FOR
SET APPTDTTM=$ORDER(^SC(SCIEN,"S",APPTDTTM))
if 'APPTDTTM
QUIT
Begin DoDot:1
+7 ;
SET IEN2=0
FOR
SET IEN2=$ORDER(^SC(SCIEN,"S",APPTDTTM,1,IEN2))
if 'IEN2
QUIT
IF $PIECE(^(IEN2,0),"^",9)'="C"
IF $$GET1^DIQ(44.003,IEN2_","_APPTDTTM_","_SCIEN,5)'="CONVERTED TO CERNER"
SET APPTCNT=APPTCNT+1
End DoDot:1
+8 ;
+9 ;
QUIT APPTCNT
+10 ;
INACTHDR(TITLE) ;
+1 ;
+2 ;
WRITE @IOF,$$CENTER^EHM13UTIL(TITLE,IOM),!
+3 ;
WRITE !,"CLINIC",?32,"STATUS",!,$$DASHES^EHM13UTIL(30),?32,$$DASHES^EHM13UTIL(45),!
+4 ;
QUIT
+5 ;
INACTVAT ;
+1 ;
+2 ; Scan clinics and inactivate them.
+3 ;
+4 ;
NEW X
IF '$$CRNRSITE^VAFCCRNR($PIECE($$SITE^VASITE(),U,3))
WRITE !!,"*** CAN BE RUN ON CONVERTED SITES ONLY ***",!
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
QUIT
+5 ;
+6 ;
NEW %DT,Y,I,SCIEN,CONVDATE,RTNCODE,DIQUIET,COUNT,CLINNAME
+7 ;
+8 ;
KILL ^TMP($JOB)
SET DIQUIET=1
+9 ;
+10 ; Enter date of conversion.
+11 ;
+12 ;
KILL %DT
SET %DT="A"
SET %DT("A")="DATE OF CONVERSION: "
DO ^%DT
if Y<0
QUIT
SET CONVDATE=+Y
+13 ;
+14 ;
WRITE !!,"*** This option INACTIVATES all eligible clinics. ***",!
+15 ;
IF $$CONTINUE()'=1
QUIT
+16 ;
+17 ; Scan clinics
+18 ;
+19 ;
SET COUNT("INACTIVATED")=0
SET COUNT("FAILED")=0
SET COUNT("FAILED","Inactive")=0
SET COUNT("FAILED","Future appointments")=0
+20 ;
+21 ;
WRITE !,"Inactivating clinics..."
+22 ;
SET SCIEN=0
FOR I=1:1
SET SCIEN=$ORDER(^SC(SCIEN))
if 'SCIEN
QUIT
if I#100=0
WRITE "."
IF $$GET1^DIQ(44,SCIEN,2)="CLINIC"
Begin DoDot:1
+23 ;
+24 ; Skip clinic that is open post go-live.
IF $DATA(^EHRM(1610,"B",SCIEN))
QUIT
+25 ;
+26 ; Skip already inactive clinic
IF $DATA(^SC(SCIEN,"I"))
IF +^("I")'=0
IF +^("I")'>DT
IF +$PIECE(^("I"),"^",2)'>0
QUIT
+27 ;
+28 ;
SET RTNCODE=$$SDNACT(SCIEN,CONVDATE)
+29 ;
IF RTNCODE
SET ^TMP($JOB,$$GET1^DIQ(44,SCIEN,.01),SCIEN)="INACTIVATED"
SET COUNT("INACTIVATED")=COUNT("INACTIVATED")+1
QUIT
+30 ;
SET ^TMP($JOB,$$GET1^DIQ(44,SCIEN,.01),SCIEN)="INACTIVATION FAILED: "_$PIECE(RTNCODE,U,2)
+31 ;
SET COUNT("FAILED")=COUNT("FAILED")+1
SET COUNT("FAILED",$PIECE(RTNCODE,U,2))=COUNT("FAILED",$PIECE(RTNCODE,U,2))+1
QUIT
End DoDot:1
+32 ;
+33 ;
WRITE !!,"CLINIC",?32,"STATUS",?46,"REASON",!
+34 ;
WRITE $$DASHES^EHM13UTIL(30),?32,$$DASHES^EHM13UTIL(11),?46,$$DASHES^EHM13UTIL(30),!
+35 ;
SET CLINNAME=""
FOR
SET CLINNAME=$ORDER(^TMP($JOB,CLINNAME))
if CLINNAME=""
QUIT
SET SCIEN=0
FOR
SET SCIEN=$ORDER(^TMP($JOB,CLINNAME,SCIEN))
if 'SCIEN
QUIT
SET X=^(SCIEN)
Begin DoDot:1
+36 ;
+37 ;
IF X["INACTIVATED"
WRITE CLINNAME,?32,"INACTIVATED",!
QUIT
+38 ;
WRITE CLINNAME,?32,"FAILED",?46,$PIECE(X,": ",2),!
End DoDot:1
+39 ;
+40 ;
WRITE !
+41 ;
WRITE "CLINICS INACTIVATED: ",COUNT("INACTIVATED"),!
+42 ;
WRITE "INACTIVATION FAILED: ",COUNT("FAILED"),!
+43 ;
WRITE ?5,"Future appointments: ",COUNT("FAILED","Future appointments"),!
+44 ;
+45 ;
KILL ^TMP($JOB)
+46 ;
QUIT
+47 ;
SDNACT(SC,SDDATE) ;ALB/TMP - INACTIVATE A CLINIC ;Mar 25, 2021@15:05:56
+1 ;
+2 ; SC = IEN of clinic in file #44
+3 ; SDDATE = Conversion date
+4 ;
+5 ; Returns 1 if inactivated or 0^error messaage if not.
+6 ;
+7 ; Cloned from SDNACT.
+8 ;
+9 ;
NEW ERRMSG,A,DA,CNT,D0,DH,DO,DOW,I,I1,J,J1,POP,SD,SD0,SDAY,SDEL,SDFSW,SDN,SDNL,SDOL,SDREACT,SI,SL,STARTDAY,SDX,SDX1,SDZQ,X,X1,X2,Y,Z,DIE,DR,DIC
+10 ;
+11 ;
SET ERRMSG=""
+12 ;
+13 SET SDAY="Sun^Mon^Tues^Wednes^Thurs^Fri^Satur"
SET SDZQ=1
+14 ;
DO DT^DICRW
+15 ;
+16 ;
SET SDX=""
SET SDX1=9999999
+17 ;
D ;
+1 ;S POP=0 F I=SDDATE-.0001:0 S I=$O(^SC(SC,"S",I)) Q:'I!(POP)!(SDDATE'<SDX1&(SDX1)) F I1=0:0 S I1=$O(^SC(SC,"S",I,1,I1)) Q:'I1 I $P(^(I1,0),"^",9)'="C",$$GET1^DIQ(44.003,I1_","_I_","_SC,5)="CONVERTED TO CERNER" S POP=1 Q
+2 ;
SET POP=$$APPTCNT(SC)
+3 ;
IF POP
SET ERRMSG="Future appointments"
GOTO END
+4 IF SDX'=""
DO CHG1
GOTO OVR
+5 KILL SDN
SET ^SC(SC,"I")=""
SET X=SDDATE
DO DOW^SDM0
SET SDN(Y)=SDDATE
FOR I=1:1:6
SET X2=1
SET X1=X
DO C^%DTC
DO DOW^SDM0
SET SDN(Y)=X
+6 FOR I=0:1:6
SET J=$ORDER(^SC(SC,"T"_I,SDN(I)))
DO GOT
OVR FOR I=SDDATE-.0001:0
SET I=$ORDER(^SC(SC,"ST",I))
if 'I!(I>SDX1)
QUIT
KILL ^(I)
+1 FOR I=SDDATE-.0001:0
SET I=$ORDER(^SC(SC,"T",I))
if 'I!(I>SDX1)
QUIT
KILL ^(I)
+2 FOR I=SDDATE-.0001:0
SET I=$ORDER(^SC(SC,"OST",I))
if 'I!(I>SDX1)
QUIT
KILL ^(I)
+3 ; Set inactive date and clear reactive date. wtc 10.10.23
SET DIE="^SC("
SET DA=SC
SET DR="2505///^S X=SDDATE;2506///"
DO ^DIE
+4 ;alb/sat 627
DO SDEC^SDNACT(SC,SDDATE)
+5 ;
GOTO END
+6 ;
CHECK ;
+1 ;
DEL ;
+1 ;
CHG1 ;;wtc ;K SDN S X1=SDDATE,X2=6 D C^%DTC S SDNL=X,X=SDDATE D DOW^SDM0 S SDN(Y)=X
+1 FOR I=1:1:6
SET X1=X
SET X2=1
DO C^%DTC
DO DOW^SDM0
SET SDN(Y)=X
+2 SET X1=SDX
SET X2=6
DO C^%DTC
SET SDOL=X
SET X1=SDX
SET X2=-1
DO C^%DTC
+3 FOR I=0:0
SET X2=1
SET X1=X
DO C^%DTC
if X>SDOL
QUIT
DO DOW^SDM0
if $DATA(^SC(SC,"T"_Y))&($ORDER(^SC(SC,"T"_Y,0))'=9999999)
SET ^SC(SC,"T"_Y,SDN(Y),1)=$SELECT($DATA(^SC(SC,"T"_Y,X,1)):^(1),1:"")
SET ^(0)=SDN(Y)
DO A1
DO A
+4 IF SDDATE<SDX
FOR I=0:1:6
FOR J=SDNL:0
SET J=$ORDER(^SC(SC,"T"_I,J))
if 'J!(J'<SDX)
QUIT
KILL ^SC(SC,"T"_I,J)
+5 QUIT
A1 if '$DATA(^SC(SC,"T"_Y,9999999,1))
SET ^(1)=""
SET ^(0)=9999999
if (SDN(Y)-X)
KILL ^SC(SC,"T"_Y,X)
+1 QUIT
A IF $ORDER(^SC(SC,"T"_Y,SDN(Y)))>0
SET SD=$ORDER(^SC(SC,"T"_Y,SDN(Y)))
if ^SC(SC,"T"_Y,SD,1)]""
SET ^SC(SC,"T"_Y,SDN(Y),1)=^SC(SC,"T"_Y,SD,1)
SET ^(0)=SDN(Y)
SET ^SC(SC,"T"_Y,SD,1)=""
+1 IF SDX'>SDDATE
IF $ORDER(^SC(SC,"ST",SDX-.1))>0
FOR Z=SDX-.1:0
SET Z=$ORDER(^SC(SC,"ST",Z))
if 'Z!(SDX1&(Z'<SDX1))
QUIT
KILL ^SC(SC,"ST",Z)
+2 KILL SD,Z
QUIT
GOT SET SD=$ORDER(^SC(SC,"T"_I,0))
+1 ;don't remove if already canceled, SD*5.3*726
IF J>0
IF SD'=9999999
IF ^SC(SC,"T"_I,J,1)'=""
SET ^SC(SC,"T"_I,SDN(I),1)=^SC(SC,"T"_I,J,1)
SET ^(0)=SDN(I)
KILL ^SC(SC,"T"_I,J)
FOR J1=J:0
SET J1=$ORDER(^SC(SC,"T"_I,J1))
if 'J1
QUIT
KILL ^SC(SC,"T"_I,J1)
+2 SET ^SC(SC,"T"_I,9999999,1)=""
SET ^(0)=9999999
+3 QUIT
END ;
+1 ;
IF $GET(ERRMSG)=""
QUIT 1
+2 ;
QUIT 0_U_ERRMSG
+3 ;
CONTINUE() ;
+1 ;
+2 ; Prompt user to continue or quit.
+3 ;
+4 ;
NEW DIR,Y,DIRUT
+5 ;
SET DIR(0)="Y"
SET DIR("A")="Are you sure?"
SET DIR("B")="NO"
DO ^DIR
+6 ;
IF $DATA(DIRUT)
QUIT 0
+7 ;
QUIT Y
+8 ;
