EHMAPPTR ; ALB/WTC - ACTIVE APPOINTMENT REPORT ; Jun 05, 2025@14:51:52
;;1.0;ELECTRONIC HEALTH MODERNIZATION;**13**;Apr 19, 2021;Build 27
;
;
Q ;
;
ACTVSLCT(RPTYPE,CONVDATE,SORTORDR,FILTER,ADDON) ;
;
; Select parameters for list or summary.
;
; RPTYPE = Report type (LIST or SUMMARY) [REQUIRED]
; CONVDATE = Date of conversion [RETURNED]
; SORTORDR = Sort order (1,2,3) [RETURNED]
; FILTER = Clinic/Stop Code filter (A=All, C^ien of file #40.7 for Stop Code, S^ien of file #44 for clinic) [RETURNED]
; ADDON = Add-on field (DENTAL) [RETURNED]
;
I $G(RPTYPE)="" Q ;
;
N DIR,Y,X ;
;
S (CONVDATE,FILTER,ADDON)="" ;
;
; Conversion date
;
S CONVDATE=$$CONVDATE^EHM13UTIL() Q:CONVDATE="" ;
;
; Sort Order
;
I $G(SORTORDR)="" S SORTORDR=$$SORTORDR^EHM13UTIL() Q:SORTORDR="" ;
;
; All clinics, single clinic or single stop code?
;
K DIR ;
S DIR(0)="SO^A:All Clinics;S:Single Clinic;C:Single Stop Code",DIR("A")="Filter",DIR("B")="All" D ^DIR Q:$D(DIRUT) "" S FILTER=Y ;
;
; Select clinic to include.
;
I FILTER="S" K DIC S DIC=44,DIC(0)="AEQM" D ^DIC Q:$D(DIRUT) "" Q:Y=-1 "" S FILTER="S"_U_(+Y) ;
;
; Select stop code to include.
;
I FILTER="C" K DIC S DIC=40.7,DIC(0)="AEQM" D ^DIC Q:$D(DIRUT) "" Q:Y=-1 "" S FILTER="C"_U_(+Y) ;
;
I RPTYPE="LIST" K DIR S DIR(0)="Y",DIR("A")="Display dental classification",DIR("B")="NO" D ^DIR Q:Y="" S ADDON=$S(Y:"DENTAL",1:"") ;
;
Q ;
;
ACTVAPPT(RPTYPE,CONVDATE,SORTORDR,FILTER,QUEUED) ;
;
; RPTYPE = Report type (LIST, SUMMARY or CLEANUP) [REQUIRED]
; CONVDATE = Date of conversion [REQUIRED]
; SORTORDR = Sort order (1,2,3) [REQUIRED]
; FILTER = Clinic or Stop Code filter [REQUIRED]
; QUEUED = 1 if report queued, 0 otherwise
;
; Active appointment list. Select active appointments after conversion date.
; Returns conversion date and filter (e.g., 20240223^A if all clinics selected, 20240223^S^123 if single clinic selected, 20240223^C^999 if stop code selected).
; List is in ^TMP($J).
;
; ^TMP($J)=SORT ORDER (1,2,3)
; ^TMP($J,sorted values,409.84)=pointer to #409.84 ^ 0 node from file #409.84
; ^TMP($J,sorted values,2)=0 node from appointment multiple in file #2
; ^TMP($J,sorted values,44)=ien of appointment multiple in file #44 ^ 0 node from appointment in file #44
;
; sorted values are made up of: appointment date/time in FileMan format (e.g., 3230701.1209)
; patient as LAST NAME,FIRST NAME ^ DFN (e.g., SMITH,JOHN A^12345)
; clinic as NAME ^ IEN in file #44. (e.g., MEDICAL CLINIC^12345)
;
N IEN,I,APPTDTTM,IEN2,X,DFN,DATENTRD,RESRC,LASTFI,IEN2,PTAPPT,SDECIEN,SDECAPPT ;
;
K ^TMP($J) ;
U 0 I 'QUEUED W !,"Scanning ",$P(^DIC(44,0),U,1)," file.",! ;
S IEN=$S($P(FILTER,U,1)="A":0,$P(FILTER,U,1)="C":0,1:$P(FILTER,U,2)-.000001),I=0 ;
;
F S IEN=$O(^SC(IEN)) Q:'IEN Q:$P(FILTER,U,1)="S"&(IEN>$P(FILTER,U,2)) I $$GET1^DIQ(44,IEN,2)="CLINIC" D ;
. I $P(FILTER,U,1)="C" Q:$P($G(^SC(IEN,0)),U,7)'=$P(FILTER,U,2) ; If filtered by stop code,ignore locations that aren't the selected stop code.
. S APPTDTTM=CONVDATE-.000001 F S APPTDTTM=$O(^SC(IEN,"S",APPTDTTM)) Q:'APPTDTTM D ;
.. S IEN2=0 F S IEN2=$O(^SC(IEN,"S",APPTDTTM,1,IEN2)) Q:'IEN2 S X=$G(^(IEN2,0)) I X'="" D ;
... ;
... Q:$P(X,U,9)="C" ; Skip if cancelled.
... S DFN=$P(X,U,1) Q:'DFN ; Skip if bad data.
... S DATENTRD=$P(X,U,7) ;
... S I=I+1 I I#100=0,'QUEUED D PROGRESS^EHM13UTIL(I) ;
... ;
... ; Find record in Patient file and in SDEC Appointment file (if present)
... ;
... S PTAPPT=$G(^DPT(DFN,"S",APPTDTTM,0)) ;
... S SDECIEN=0 F S SDECIEN=$O(^SDEC(409.84,"B",APPTDTTM,SDECIEN)) Q:'SDECIEN S SDECAPPT=$G(^SDEC(409.84,SDECIEN,0)) I $P(SDECAPPT,U,5)=DFN,$P(SDECAPPT,U,12)="" Q ;
... I 'SDECIEN S SDECAPPT="" ;
... ;
... I SORTORDR=1 D Q ;
.... S ^TMP($J,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,$$GET1^DIQ(44,IEN,.01)_U_IEN,44)=IEN2_U_X ;
.... I PTAPPT'="" S ^TMP($J,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,$$GET1^DIQ(44,IEN,.01)_U_IEN,2)=PTAPPT ;
.... I SDECIEN S ^TMP($J,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,$$GET1^DIQ(44,IEN,.01)_U_IEN,409.84)=SDECIEN_U_SDECAPPT ;
... ;
... I SORTORDR=2 D Q ;
.... S ^TMP($J,$$GET1^DIQ(44,IEN,.01)_U_IEN,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,44)=IEN2_U_X ;
.... I PTAPPT'="" S ^TMP($J,$$GET1^DIQ(44,IEN,.01)_U_IEN,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,2)=PTAPPT ;
.... I SDECIEN S ^TMP($J,$$GET1^DIQ(44,IEN,.01)_U_IEN,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,409.84)=SDECIEN_U_SDECAPPT ;
... ;
... I SORTORDR=3 D Q ;
.... S ^TMP($J,$$GET1^DIQ(2,DFN,.01)_U_DFN,APPTDTTM,$$GET1^DIQ(44,IEN,.01)_U_IEN,44)=IEN2_U_X ;
.... I PTAPPT'="" S ^TMP($J,$$GET1^DIQ(2,DFN,.01)_U_DFN,APPTDTTM,$$GET1^DIQ(44,IEN,.01)_U_IEN,2)=PTAPPT ;
.... I SDECIEN S ^TMP($J,$$GET1^DIQ(2,DFN,.01)_U_DFN,APPTDTTM,$$GET1^DIQ(44,IEN,.01)_U_IEN,409.84)=SDECIEN_U_SDECAPPT ;
;
Q ;
;
ACTVLIST ;
;
; List active appointments after conversion.
;
N RPTYPE,CONVDATE,SORTORDR,FILTER,ADDON,OUTPTFMT,X,Y,POP,%ZIS,DIRUT,QUEUED ;
;
S RPTYPE="LIST" D ACTVSLCT(RPTYPE,.CONVDATE,.SORTORDR,.FILTER,.ADDON) Q:$D(DIRUT) Q:CONVDATE="" Q:SORTORDR="" Q:FILTER="" ;
;
; Output format
;
S OUTPTFMT=$$RPTFMT^EHM13UTIL() Q:OUTPTFMT="" ;
;
S %ZIS="Q" D ^%ZIS I POP K ^TMP($J) 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="ACTVLST1^EHMAPPTR",ZTDESC="Appointment List" ;
. S ZTSAVE("*")="" ;
. D ^%ZTLOAD W $S($D(ZTSK):"...Task queued",1:"...Task cancelled"),! ;
;
ACTVLST1 ; TaskMan start point
;
; Build list of converted appointments.
;
U IO D ACTVAPPT(RPTYPE,CONVDATE,SORTORDR,FILTER,QUEUED) ;
;
; List appointments
;
I OUTPTFMT="F" D APPTLSTF("Active Appointment List",CONVDATE,SORTORDR,$G(ADDON),FILTER,QUEUED) ; Formatted report
I OUTPTFMT="C" D APPTLSTC("Active Appointment List",SORTORDR,$G(ADDON)) ; Comma-delimited file
;
U 0 I 'QUEUED,IO=$I R !,"Press [RETURN] to continue",X:$G(DTIME,300) ;
;
D ^%ZISC ;
K ^TMP($J) ;
Q ;
;
SUMMARY ;
;
; Output summary of active appointments.
;
N CONVDATE,POP,%ZIS,DIRUT,QUEUED ;
;
S RPTYPE="SUMMARY" D ACTVSLCT(RPTYPE,.CONVDATE,1,.FILTER,.ADDON) Q:$D(DIRUT) Q:CONVDATE="" Q:FILTER="" ;
;
S %ZIS="Q" D ^%ZIS I POP K ^TMP($J) 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="SUMMARY1^EHMAPPTR",ZTDESC="Appointment Summary" ;
. S ZTSAVE("*")="" ;
. D ^%ZTLOAD W $S($D(ZTSK):"...Task queued",1:"...Task cancelled"),! ;
;
SUMMARY1 ; TaskMan entry point
;
; Output summary report.
;
N TITLE ;
;
; Build list of appointments.
;
U IO D ACTVAPPT(RPTYPE,CONVDATE,1,FILTER,QUEUED) ;
;
; Output summary report.
;
S TITLE(1)="ACTIVE APPOINTMENT SUMMARY" ;
I $P(FILTER,U,1)="S" S TITLE(2)="CLINIC: "_$$GET1^DIQ(44,$P(FILTER,U,2),.01) ;
I $P(FILTER,U,1)="C" S TITLE(2)="STOP CODE: "_$$GET1^DIQ(40.7,$P(FILTER,U,2),.01) ;
D SUMOUT^EHMAPPT2(.TITLE,CONVDATE,QUEUED) ;
Q ;
;
APPTLSTF(TITLE,CONVDATE,SORTORDR,ADDON,FILTER,QUEUED) ; Formatted Report
;
N LINES,QUIT,SDECIEN,SDECAPPT,PTAPPT,SCAPPT,SORT1,SORT2,SORT3,APPTDTTM,DFN,CLINIC,RECRDCT ;
N WIDTH S WIDTH(1)=30,WIDTH(2)=11,WIDTH(3)=30,WIDTH(4)=14,WIDTH(5)=30 ;
I $G(ADDON)="DENTAL" S WIDTH(6)=50 ;
;
U IO D HEADER(TITLE,CONVDATE,SORTORDR,ADDON,FILTER) ;
S LINES=0,QUIT=0,RECRDCT=0 ;
;
; Scan sorted data in ^TMP($J)
;
S SORT1="" F S SORT1=$O(^TMP($J,SORT1)) Q:SORT1="" D Q:QUIT ;
. S SORT2="" F S SORT2=$O(^TMP($J,SORT1,SORT2)) Q:SORT2="" D Q:QUIT ;
.. S SORT3="" F S SORT3=$O(^TMP($J,SORT1,SORT2,SORT3)) Q:SORT3="" D Q:QUIT ;
... I SORTORDR=1 S APPTDTTM=SORT1,DFN=$P(SORT2,U,2),CLINIC=$P(SORT3,U,2) ;
... I SORTORDR=2 S CLINIC=$P(SORT1,U,2),APPTDTTM=SORT2,DFN=$P(SORT3,U,2) ;
... I SORTORDR=3 S DFN=$P(SORT1,U,2),APPTDTTM=SORT2,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)) ;
... S SCAPPT=$G(^TMP($J,SORT1,SORT2,SORT3,44)) ;
... K VADM D DEM^VADPT ;
... ;
... I 'QUEUED D Q:QUIT ;
.... U 0 ;
.... I IO=$I Q:LINES<(IOSL-7) S QUIT=$$CONTINUE^EHM13UTIL()=0 Q:QUIT U IO D HEADER(TITLE,CONVDATE,SORTORDR,ADDON,FILTER) S LINES=1 Q ;
.... ;
.... ; New page header for printed report
.... ;
.... I LINES'<IOSL U IO D HEADER(TITLE,CONVDATE,SORTORDR,ADDON,FILTER) S LINES=1 ;
... ;
... U IO ;
... I SORTORDR=1 D ;
.... S WIDTH=0 W $$FMTDTTM^EHM13UTIL(APPTDTTM) S WIDTH=WIDTH+WIDTH(4)+2 ;
.... W ?WIDTH,VADM(1) S WIDTH=WIDTH+WIDTH(1)+2 ;
.... W ?WIDTH,$P(VADM(3),U,2) S WIDTH=WIDTH+WIDTH(2)+2 ;
.... W ?WIDTH,$$EDIPI(DFN,$P($$SITE^VASITE(),U,3)) S WIDTH=WIDTH+WIDTH(3)+2 ;
.... W ?WIDTH,$$GET1^DIQ(44,CLINIC,.01) S WIDTH=WIDTH+WIDTH(5)+2 ;
.... I $G(ADDON)="DENTAL" W ?WIDTH,$$GET1^DIQ(220,DFN,70.01)
.... W ! ;
... ;
... I SORTORDR=2 D ;
.... S WIDTH=0 W $$GET1^DIQ(44,CLINIC,.01) S WIDTH=WIDTH+WIDTH(5)+2 ;
.... W ?WIDTH,$$FMTDTTM^EHM13UTIL(APPTDTTM) S WIDTH=WIDTH+WIDTH(4)+2 ;
.... W ?WIDTH,VADM(1) S WIDTH=WIDTH+WIDTH(1)+2 ;
.... W ?WIDTH,$P(VADM(3),U,2) S WIDTH=WIDTH+WIDTH(2)+2 ;
.... W ?WIDTH,$$EDIPI(DFN,$P($$SITE^VASITE(),U,3)) S WIDTH=WIDTH+WIDTH(3)+2 ;
.... I $G(ADDON)="DENTAL" W ?WIDTH,$$GET1^DIQ(220,DFN,70.01)
.... W ! ;
... ;
... I SORTORDR=3 D ;
.... S WIDTH=0 W VADM(1) S WIDTH=WIDTH+WIDTH(1)+2 ;
.... W ?WIDTH,$P(VADM(3),U,2) S WIDTH=WIDTH+WIDTH(2)+2 ;
.... W ?WIDTH,$$EDIPI(DFN,$P($$SITE^VASITE(),U,3)) S WIDTH=WIDTH+WIDTH(3)+2 ;
.... W ?WIDTH,$$FMTDTTM^EHM13UTIL(APPTDTTM) S WIDTH=WIDTH+WIDTH(4)+2 ;
.... W ?WIDTH,$$GET1^DIQ(44,CLINIC,.01) S WIDTH=WIDTH+WIDTH(5)+2 ;
.... I $G(ADDON)="DENTAL" W ?WIDTH,$$GET1^DIQ(220,DFN,70.01)
.... W ! ;
... ;
... S LINES=LINES+1,RECRDCT=RECRDCT+1 ;
W !,"TOTAL RECORDS = ",RECRDCT,! ;
;
Q ;
;
APPTLSTC(TITLE,SORTORDR,TYPE) ; Comma-delimited file
;
N SORT1,SORT2,SORT3,APPTDTTM,DFN,CLINIC,SDECIEN,SDECAPPT,PTAPPT,SCAPPT ;
;
U IO ;
;
; Output first row - list of data fields
;
N HDR S HDR(1)="Patient",HDR(2)="DOB",HDR(3)="EDIPI",HDR(4)="Appt Date/Time",HDR(5)="Clinic" ;
I $G(TYPE)="DENTAL" S HDR(6)="Dental Classification" ;
;
I SORTORDR=1 D ;
. I $G(TYPE)="DENTAL" W $$COMMAOUT^EHM13UTIL(6,HDR(4),HDR(1),HDR(2),HDR(3),HDR(5),HDR(6)),! ;
. E W $$COMMAOUT^EHM13UTIL(5,HDR(4),HDR(1),HDR(2),HDR(3),HDR(5)),! ;
I SORTORDR=2 D ;
. I $G(TYPE)="DENTAL" W $$COMMAOUT^EHM13UTIL(6,HDR(5),HDR(4),HDR(1),HDR(2),HDR(3),HDR(6)),! ;
. E W $$COMMAOUT^EHM13UTIL(5,HDR(5),HDR(4),HDR(1),HDR(2),HDR(3)),! ;
I SORTORDR=3 D ;
. I $G(TYPE)="DENTAL" W $$COMMAOUT^EHM13UTIL(6,HDR(1),HDR(2),HDR(3),HDR(4),HDR(5),HDR(6)),! ;
. E W $$COMMAOUT^EHM13UTIL(5,HDR(1),HDR(2),HDR(3),HDR(4),HDR(5)),! ;
;
; 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 ;
... I SORTORDR=1 S APPTDTTM=SORT1,DFN=$P(SORT2,U,2),CLINIC=$P(SORT3,U,2) ;
... I SORTORDR=2 S CLINIC=$P(SORT1,U,2),APPTDTTM=SORT2,DFN=$P(SORT3,U,2) ;
... I SORTORDR=3 S DFN=$P(SORT1,U,2),APPTDTTM=SORT2,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)) ;
... S SCAPPT=$G(^TMP($J,SORT1,SORT2,SORT3,44)) ;
... K VADM D DEM^VADPT ;
... ;
... I SORTORDR=1 D ;
.... I $G(TYPE)="DENTAL" W $$COMMAOUT^EHM13UTIL(6,$$FMTDTTM^EHM13UTIL(APPTDTTM),VADM(1),$P(VADM(3),U,2),$$EDIPI(DFN,$P($$SITE^VASITE(),U,3)),$$GET1^DIQ(44,CLINIC,.01),$$GET1^DIQ(220,DFN,70.01)),! ;
.... E W $$COMMAOUT^EHM13UTIL(5,$$FMTDTTM^EHM13UTIL(APPTDTTM),VADM(1),$P(VADM(3),U,2),$$EDIPI(DFN,$P($$SITE^VASITE(),U,3)),$$GET1^DIQ(44,CLINIC,.01)),! ;
... I SORTORDR=2 D ;
.... I $G(TYPE)="DENTAL" W $$COMMAOUT^EHM13UTIL(6,$$GET1^DIQ(44,CLINIC,.01),$$FMTDTTM^EHM13UTIL(APPTDTTM),VADM(1),$P(VADM(3),U,2),$$EDIPI(DFN,$P($$SITE^VASITE(),U,3)),$$GET1^DIQ(220,DFN,70.01)),! ;
.... E W $$COMMAOUT^EHM13UTIL(5,$$GET1^DIQ(44,CLINIC,.01),$$FMTDTTM^EHM13UTIL(APPTDTTM),VADM(1),$P(VADM(3),U,2),$$EDIPI(DFN,$P($$SITE^VASITE(),U,3))),! ;
... I SORTORDR=3 D ;
.... I $G(TYPE)="DENTAL" W $$COMMAOUT^EHM13UTIL(6,VADM(1),$P(VADM(3),U,2),$$EDIPI(DFN,$P($$SITE^VASITE(),U,3)),$$FMTDTTM^EHM13UTIL(APPTDTTM),$$GET1^DIQ(44,CLINIC,.01),$$GET1^DIQ(220,DFN,70.01)),! ;
.... E W $$COMMAOUT^EHM13UTIL(5,VADM(1),$P(VADM(3),U,2),$$EDIPI(DFN,$P($$SITE^VASITE(),U,3)),$$FMTDTTM^EHM13UTIL(APPTDTTM),$$GET1^DIQ(44,CLINIC,.01)),! ;
;
Q ;
;
;
; TITLE = Report title
; CONVDATE = Conversion date (FM format)
; SORTORDR = Sort order (1,2,3)
; TYPE (see POSTLIST)
; FILTER = "A" if all clinics selected, "S^ien in #44" if single clinic selected, "C^ien in #40.7 if single stop code selected.
;
W @IOF,$$CENTER^EHM13UTIL(TITLE_" - Station "_$P($$SITE^VASITE(),U,3),$G(IOM,80)),! ;
I $P($G(FILTER),U,1)="S" W $$CENTER^EHM13UTIL("CLINIC: "_$$GET1^DIQ(44,$P(FILTER,U,2),.01),$G(IOM,80)),! ;
I $P($G(FILTER),U,1)="C" W $$CENTER^EHM13UTIL("STOP CODE: "_$$GET1^DIQ(40.7,$P(FILTER,U,2),.01),$G(IOM,80)),! ;
W:$G(CONVDATE)'="" $$CENTER^EHM13UTIL("Conversion Date: "_$$FMTE^XLFDT(CONVDATE),$G(IOM,80)),! W ! ;
;
N HDR S HDR(1)="Patient",HDR(2)="DOB",HDR(3)="EDIPI",HDR(4)="Appt Date/Time",HDR(5)="Clinic" ;
N WIDTH S WIDTH(1)=30,WIDTH(2)=11,WIDTH(3)=30,WIDTH(4)=14,WIDTH(5)=30 ;
;
I $G(TYPE)="DENTAL" S HDR(6)="Dental Classification",WIDTH(6)=50 ;
;
N IDX ;
I SORTORDR=1 D ;
. S WIDTH=0 ;
. F IDX=4,1,2,3,5,$S($G(TYPE)'="":6,1:"") I IDX W ?WIDTH,HDR(IDX) S WIDTH=WIDTH+WIDTH(IDX)+2 ;
. W ! ;
. S WIDTH=0 ;
. F IDX=4,1,2,3,5,$S($G(TYPE)'="":6,1:"") I IDX W ?WIDTH,$$DASHES^EHM13UTIL(WIDTH(IDX)) S WIDTH=WIDTH+WIDTH(IDX)+2 ;
. W ! ;
;
I SORTORDR=2 D ;
. S WIDTH=0 ;
. F IDX=5,4,1,2,3,$S($G(TYPE)'="":6,1:"") I IDX W ?WIDTH,HDR(IDX) S WIDTH=WIDTH+WIDTH(IDX)+2 ;
. W ! ;
. S WIDTH=0 ;
. F IDX=5,4,1,2,3,$S($G(TYPE)'="":6,1:"") I IDX W ?WIDTH,$$DASHES^EHM13UTIL(WIDTH(IDX)) S WIDTH=WIDTH+WIDTH(IDX)+2 ;
. W ! ;
;
I SORTORDR=3 D ;
. S WIDTH=0 ;
. F IDX=1,2,3,4,5,$S($G(TYPE)'="":6,1:"") I IDX W ?WIDTH,HDR(IDX) S WIDTH=WIDTH+WIDTH(IDX)+2 ;
. W ! ;
. S WIDTH=0 ;
. F IDX=1,2,3,4,5,$S($G(TYPE)'="":6,1:"") I IDX W ?WIDTH,$$DASHES^EHM13UTIL(WIDTH(IDX)) S WIDTH=WIDTH+WIDTH(IDX)+2 ;
. W ! ;
;
Q ;
;
EDIPI(DFN,SITE) ;
;
; Return patient's EDIPI
;
N TFLIST,I,EDIPI ;
;
D TFL^VAFCTFU2(.TFLIST,DFN_U_"PI"_U_"USVHA"_U_SITE) ; icr #4648
;
S EDIPI="" F I=1:1 Q:'$D(TFLIST(I)) I $P(TFLIST(I),U,2)="NI",$P(TFLIST(I),U,3)="USDOD",$P(TFLIST(I),U,4)="200DOD",$P(TFLIST(I),U,5)="A" S EDIPI=$P(TFLIST(I),U,1) Q ;
;
Q EDIPI ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEHMAPPTR 15222 printed Apr 22, 2026@13:48:21 Page 2
EHMAPPTR ; ALB/WTC - ACTIVE APPOINTMENT REPORT ; Jun 05, 2025@14:51:52
+1 ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**13**;Apr 19, 2021;Build 27
+2 ;
+3 ;
+4 ;
QUIT
+5 ;
ACTVSLCT(RPTYPE,CONVDATE,SORTORDR,FILTER,ADDON) ;
+1 ;
+2 ; Select parameters for list or summary.
+3 ;
+4 ; RPTYPE = Report type (LIST or SUMMARY) [REQUIRED]
+5 ; CONVDATE = Date of conversion [RETURNED]
+6 ; SORTORDR = Sort order (1,2,3) [RETURNED]
+7 ; FILTER = Clinic/Stop Code filter (A=All, C^ien of file #40.7 for Stop Code, S^ien of file #44 for clinic) [RETURNED]
+8 ; ADDON = Add-on field (DENTAL) [RETURNED]
+9 ;
+10 ;
IF $GET(RPTYPE)=""
QUIT
+11 ;
+12 ;
NEW DIR,Y,X
+13 ;
+14 ;
SET (CONVDATE,FILTER,ADDON)=""
+15 ;
+16 ; Conversion date
+17 ;
+18 ;
SET CONVDATE=$$CONVDATE^EHM13UTIL()
if CONVDATE=""
QUIT
+19 ;
+20 ; Sort Order
+21 ;
+22 ;
IF $GET(SORTORDR)=""
SET SORTORDR=$$SORTORDR^EHM13UTIL()
if SORTORDR=""
QUIT
+23 ;
+24 ; All clinics, single clinic or single stop code?
+25 ;
+26 ;
KILL DIR
+27 ;
SET DIR(0)="SO^A:All Clinics;S:Single Clinic;C:Single Stop Code"
SET DIR("A")="Filter"
SET DIR("B")="All"
DO ^DIR
if $DATA(DIRUT)
QUIT ""
SET FILTER=Y
+28 ;
+29 ; Select clinic to include.
+30 ;
+31 ;
IF FILTER="S"
KILL DIC
SET DIC=44
SET DIC(0)="AEQM"
DO ^DIC
if $DATA(DIRUT)
QUIT ""
if Y=-1
QUIT ""
SET FILTER="S"_U_(+Y)
+32 ;
+33 ; Select stop code to include.
+34 ;
+35 ;
IF FILTER="C"
KILL DIC
SET DIC=40.7
SET DIC(0)="AEQM"
DO ^DIC
if $DATA(DIRUT)
QUIT ""
if Y=-1
QUIT ""
SET FILTER="C"_U_(+Y)
+36 ;
+37 ;
IF RPTYPE="LIST"
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Display dental classification"
SET DIR("B")="NO"
DO ^DIR
if Y=""
QUIT
SET ADDON=$SELECT(Y:"DENTAL",1:"")
+38 ;
+39 ;
QUIT
+40 ;
ACTVAPPT(RPTYPE,CONVDATE,SORTORDR,FILTER,QUEUED) ;
+1 ;
+2 ; RPTYPE = Report type (LIST, SUMMARY or CLEANUP) [REQUIRED]
+3 ; CONVDATE = Date of conversion [REQUIRED]
+4 ; SORTORDR = Sort order (1,2,3) [REQUIRED]
+5 ; FILTER = Clinic or Stop Code filter [REQUIRED]
+6 ; QUEUED = 1 if report queued, 0 otherwise
+7 ;
+8 ; Active appointment list. Select active appointments after conversion date.
+9 ; Returns conversion date and filter (e.g., 20240223^A if all clinics selected, 20240223^S^123 if single clinic selected, 20240223^C^999 if stop code selected).
+10 ; List is in ^TMP($J).
+11 ;
+12 ; ^TMP($J)=SORT ORDER (1,2,3)
+13 ; ^TMP($J,sorted values,409.84)=pointer to #409.84 ^ 0 node from file #409.84
+14 ; ^TMP($J,sorted values,2)=0 node from appointment multiple in file #2
+15 ; ^TMP($J,sorted values,44)=ien of appointment multiple in file #44 ^ 0 node from appointment in file #44
+16 ;
+17 ; sorted values are made up of: appointment date/time in FileMan format (e.g., 3230701.1209)
+18 ; patient as LAST NAME,FIRST NAME ^ DFN (e.g., SMITH,JOHN A^12345)
+19 ; clinic as NAME ^ IEN in file #44. (e.g., MEDICAL CLINIC^12345)
+20 ;
+21 ;
NEW IEN,I,APPTDTTM,IEN2,X,DFN,DATENTRD,RESRC,LASTFI,IEN2,PTAPPT,SDECIEN,SDECAPPT
+22 ;
+23 ;
KILL ^TMP($JOB)
+24 ;
USE 0
IF 'QUEUED
WRITE !,"Scanning ",$PIECE(^DIC(44,0),U,1)," file.",!
+25 ;
SET IEN=$SELECT($PIECE(FILTER,U,1)="A":0,$PIECE(FILTER,U,1)="C":0,1:$PIECE(FILTER,U,2)-.000001)
SET I=0
+26 ;
+27 ;
FOR
SET IEN=$ORDER(^SC(IEN))
if 'IEN
QUIT
if $PIECE(FILTER,U,1)="S"&(IEN>$PIECE(FILTER,U,2))
QUIT
IF $$GET1^DIQ(44,IEN,2)="CLINIC"
Begin DoDot:1
+28 ; If filtered by stop code,ignore locations that aren't the selected stop code.
IF $PIECE(FILTER,U,1)="C"
if $PIECE($GET(^SC(IEN,0)),U,7)'=$PIECE(FILTER,U,2)
QUIT
+29 ;
SET APPTDTTM=CONVDATE-.000001
FOR
SET APPTDTTM=$ORDER(^SC(IEN,"S",APPTDTTM))
if 'APPTDTTM
QUIT
Begin DoDot:2
+30 ;
SET IEN2=0
FOR
SET IEN2=$ORDER(^SC(IEN,"S",APPTDTTM,1,IEN2))
if 'IEN2
QUIT
SET X=$GET(^(IEN2,0))
IF X'=""
Begin DoDot:3
+31 ;
+32 ; Skip if cancelled.
if $PIECE(X,U,9)="C"
QUIT
+33 ; Skip if bad data.
SET DFN=$PIECE(X,U,1)
if 'DFN
QUIT
+34 ;
SET DATENTRD=$PIECE(X,U,7)
+35 ;
SET I=I+1
IF I#100=0
IF 'QUEUED
DO PROGRESS^EHM13UTIL(I)
+36 ;
+37 ; Find record in Patient file and in SDEC Appointment file (if present)
+38 ;
+39 ;
SET PTAPPT=$GET(^DPT(DFN,"S",APPTDTTM,0))
+40 ;
SET SDECIEN=0
FOR
SET SDECIEN=$ORDER(^SDEC(409.84,"B",APPTDTTM,SDECIEN))
if 'SDECIEN
QUIT
SET SDECAPPT=$GET(^SDEC(409.84,SDECIEN,0))
IF $PIECE(SDECAPPT,U,5)=DFN
IF $PIECE(SDECAPPT,U,12)=""
QUIT
+41 ;
IF 'SDECIEN
SET SDECAPPT=""
+42 ;
+43 ;
IF SORTORDR=1
Begin DoDot:4
+44 ;
SET ^TMP($JOB,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,$$GET1^DIQ(44,IEN,.01)_U_IEN,44)=IEN2_U_X
+45 ;
IF PTAPPT'=""
SET ^TMP($JOB,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,$$GET1^DIQ(44,IEN,.01)_U_IEN,2)=PTAPPT
+46 ;
IF SDECIEN
SET ^TMP($JOB,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,$$GET1^DIQ(44,IEN,.01)_U_IEN,409.84)=SDECIEN_U_SDECAPPT
End DoDot:4
QUIT
+47 ;
+48 ;
IF SORTORDR=2
Begin DoDot:4
+49 ;
SET ^TMP($JOB,$$GET1^DIQ(44,IEN,.01)_U_IEN,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,44)=IEN2_U_X
+50 ;
IF PTAPPT'=""
SET ^TMP($JOB,$$GET1^DIQ(44,IEN,.01)_U_IEN,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,2)=PTAPPT
+51 ;
IF SDECIEN
SET ^TMP($JOB,$$GET1^DIQ(44,IEN,.01)_U_IEN,APPTDTTM,$$GET1^DIQ(2,DFN,.01)_U_DFN,409.84)=SDECIEN_U_SDECAPPT
End DoDot:4
QUIT
+52 ;
+53 ;
IF SORTORDR=3
Begin DoDot:4
+54 ;
SET ^TMP($JOB,$$GET1^DIQ(2,DFN,.01)_U_DFN,APPTDTTM,$$GET1^DIQ(44,IEN,.01)_U_IEN,44)=IEN2_U_X
+55 ;
IF PTAPPT'=""
SET ^TMP($JOB,$$GET1^DIQ(2,DFN,.01)_U_DFN,APPTDTTM,$$GET1^DIQ(44,IEN,.01)_U_IEN,2)=PTAPPT
+56 ;
IF SDECIEN
SET ^TMP($JOB,$$GET1^DIQ(2,DFN,.01)_U_DFN,APPTDTTM,$$GET1^DIQ(44,IEN,.01)_U_IEN,409.84)=SDECIEN_U_SDECAPPT
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+57 ;
+58 ;
QUIT
+59 ;
ACTVLIST ;
+1 ;
+2 ; List active appointments after conversion.
+3 ;
+4 ;
NEW RPTYPE,CONVDATE,SORTORDR,FILTER,ADDON,OUTPTFMT,X,Y,POP,%ZIS,DIRUT,QUEUED
+5 ;
+6 ;
SET RPTYPE="LIST"
DO ACTVSLCT(RPTYPE,.CONVDATE,.SORTORDR,.FILTER,.ADDON)
if $DATA(DIRUT)
QUIT
if CONVDATE=""
QUIT
if SORTORDR=""
QUIT
if FILTER=""
QUIT
+7 ;
+8 ; Output format
+9 ;
+10 ;
SET OUTPTFMT=$$RPTFMT^EHM13UTIL()
if OUTPTFMT=""
QUIT
+11 ;
+12 ;
SET %ZIS="Q"
DO ^%ZIS
IF POP
KILL ^TMP($JOB)
QUIT
+13 ;
+14 ; If report is queued, add to Taskman
+15 ;
+16 ;
SET QUEUED=0
IF $DATA(IO("Q"))
SET QUEUED=1
Begin DoDot:1
+17 ;
NEW ZTDESC,ZTRTN,ZTSAVE,ZTSK
+18 ;
SET ZTRTN="ACTVLST1^EHMAPPTR"
SET ZTDESC="Appointment List"
+19 ;
SET ZTSAVE("*")=""
+20 ;
DO ^%ZTLOAD
WRITE $SELECT($DATA(ZTSK):"...Task queued",1:"...Task cancelled"),!
End DoDot:1
QUIT
+21 ;
ACTVLST1 ; TaskMan start point
+1 ;
+2 ; Build list of converted appointments.
+3 ;
+4 ;
USE IO
DO ACTVAPPT(RPTYPE,CONVDATE,SORTORDR,FILTER,QUEUED)
+5 ;
+6 ; List appointments
+7 ;
+8 ; Formatted report
IF OUTPTFMT="F"
DO APPTLSTF("Active Appointment List",CONVDATE,SORTORDR,$GET(ADDON),FILTER,QUEUED)
+9 ; Comma-delimited file
IF OUTPTFMT="C"
DO APPTLSTC("Active Appointment List",SORTORDR,$GET(ADDON))
+10 ;
+11 ;
USE 0
IF 'QUEUED
IF IO=$IO
READ !,"Press [RETURN] to continue",X:$GET(DTIME,300)
+12 ;
+13 ;
DO ^%ZISC
+14 ;
KILL ^TMP($JOB)
+15 ;
QUIT
+16 ;
SUMMARY ;
+1 ;
+2 ; Output summary of active appointments.
+3 ;
+4 ;
NEW CONVDATE,POP,%ZIS,DIRUT,QUEUED
+5 ;
+6 ;
SET RPTYPE="SUMMARY"
DO ACTVSLCT(RPTYPE,.CONVDATE,1,.FILTER,.ADDON)
if $DATA(DIRUT)
QUIT
if CONVDATE=""
QUIT
if FILTER=""
QUIT
+7 ;
+8 ;
SET %ZIS="Q"
DO ^%ZIS
IF POP
KILL ^TMP($JOB)
QUIT
+9 ;
+10 ; If report is queued, add to Taskman
+11 ;
+12 ;
SET QUEUED=0
IF $DATA(IO("Q"))
SET QUEUED=1
Begin DoDot:1
+13 ;
NEW ZTDESC,ZTRTN,ZTSAVE,ZTSK
+14 ;
SET ZTRTN="SUMMARY1^EHMAPPTR"
SET ZTDESC="Appointment Summary"
+15 ;
SET ZTSAVE("*")=""
+16 ;
DO ^%ZTLOAD
WRITE $SELECT($DATA(ZTSK):"...Task queued",1:"...Task cancelled"),!
End DoDot:1
QUIT
+17 ;
SUMMARY1 ; TaskMan entry point
+1 ;
+2 ; Output summary report.
+3 ;
+4 ;
NEW TITLE
+5 ;
+6 ; Build list of appointments.
+7 ;
+8 ;
USE IO
DO ACTVAPPT(RPTYPE,CONVDATE,1,FILTER,QUEUED)
+9 ;
+10 ; Output summary report.
+11 ;
+12 ;
SET TITLE(1)="ACTIVE APPOINTMENT SUMMARY"
+13 ;
IF $PIECE(FILTER,U,1)="S"
SET TITLE(2)="CLINIC: "_$$GET1^DIQ(44,$PIECE(FILTER,U,2),.01)
+14 ;
IF $PIECE(FILTER,U,1)="C"
SET TITLE(2)="STOP CODE: "_$$GET1^DIQ(40.7,$PIECE(FILTER,U,2),.01)
+15 ;
DO SUMOUT^EHMAPPT2(.TITLE,CONVDATE,QUEUED)
+16 ;
QUIT
+17 ;
APPTLSTF(TITLE,CONVDATE,SORTORDR,ADDON,FILTER,QUEUED) ; Formatted Report
+1 ;
+2 ;
NEW LINES,QUIT,SDECIEN,SDECAPPT,PTAPPT,SCAPPT,SORT1,SORT2,SORT3,APPTDTTM,DFN,CLINIC,RECRDCT
+3 ;
NEW WIDTH
SET WIDTH(1)=30
SET WIDTH(2)=11
SET WIDTH(3)=30
SET WIDTH(4)=14
SET WIDTH(5)=30
+4 ;
IF $GET(ADDON)="DENTAL"
SET WIDTH(6)=50
+5 ;
+6 ;
USE IO
DO HEADER(TITLE,CONVDATE,SORTORDR,ADDON,FILTER)
+7 ;
SET LINES=0
SET QUIT=0
SET RECRDCT=0
+8 ;
+9 ; Scan sorted data in ^TMP($J)
+10 ;
+11 ;
SET SORT1=""
FOR
SET SORT1=$ORDER(^TMP($JOB,SORT1))
if SORT1=""
QUIT
Begin DoDot:1
+12 ;
SET SORT2=""
FOR
SET SORT2=$ORDER(^TMP($JOB,SORT1,SORT2))
if SORT2=""
QUIT
Begin DoDot:2
+13 ;
SET SORT3=""
FOR
SET SORT3=$ORDER(^TMP($JOB,SORT1,SORT2,SORT3))
if SORT3=""
QUIT
Begin DoDot:3
+14 ;
IF SORTORDR=1
SET APPTDTTM=SORT1
SET DFN=$PIECE(SORT2,U,2)
SET CLINIC=$PIECE(SORT3,U,2)
+15 ;
IF SORTORDR=2
SET CLINIC=$PIECE(SORT1,U,2)
SET APPTDTTM=SORT2
SET DFN=$PIECE(SORT3,U,2)
+16 ;
IF SORTORDR=3
SET DFN=$PIECE(SORT1,U,2)
SET APPTDTTM=SORT2
SET CLINIC=$PIECE(SORT3,U,2)
+17 ;
+18 ;
SET SDECAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,409.84))
SET SDECIEN=$PIECE(SDECAPPT,U,1)
SET SDECAPPT=$PIECE(SDECAPPT,U,2,999)
+19 ;
SET PTAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,2))
+20 ;
SET SCAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,44))
+21 ;
KILL VADM
DO DEM^VADPT
+22 ;
+23 ;
IF 'QUEUED
Begin DoDot:4
+24 ;
USE 0
+25 ;
IF IO=$IO
if LINES<(IOSL-7)
QUIT
SET QUIT=$$CONTINUE^EHM13UTIL()=0
if QUIT
QUIT
USE IO
DO HEADER(TITLE,CONVDATE,SORTORDR,ADDON,FILTER)
SET LINES=1
QUIT
+26 ;
+27 ; New page header for printed report
+28 ;
+29 ;
IF LINES'<IOSL
USE IO
DO HEADER(TITLE,CONVDATE,SORTORDR,ADDON,FILTER)
SET LINES=1
End DoDot:4
if QUIT
QUIT
+30 ;
+31 ;
USE IO
+32 ;
IF SORTORDR=1
Begin DoDot:4
+33 ;
SET WIDTH=0
WRITE $$FMTDTTM^EHM13UTIL(APPTDTTM)
SET WIDTH=WIDTH+WIDTH(4)+2
+34 ;
WRITE ?WIDTH,VADM(1)
SET WIDTH=WIDTH+WIDTH(1)+2
+35 ;
WRITE ?WIDTH,$PIECE(VADM(3),U,2)
SET WIDTH=WIDTH+WIDTH(2)+2
+36 ;
WRITE ?WIDTH,$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3))
SET WIDTH=WIDTH+WIDTH(3)+2
+37 ;
WRITE ?WIDTH,$$GET1^DIQ(44,CLINIC,.01)
SET WIDTH=WIDTH+WIDTH(5)+2
+38 IF $GET(ADDON)="DENTAL"
WRITE ?WIDTH,$$GET1^DIQ(220,DFN,70.01)
+39 ;
WRITE !
End DoDot:4
+40 ;
+41 ;
IF SORTORDR=2
Begin DoDot:4
+42 ;
SET WIDTH=0
WRITE $$GET1^DIQ(44,CLINIC,.01)
SET WIDTH=WIDTH+WIDTH(5)+2
+43 ;
WRITE ?WIDTH,$$FMTDTTM^EHM13UTIL(APPTDTTM)
SET WIDTH=WIDTH+WIDTH(4)+2
+44 ;
WRITE ?WIDTH,VADM(1)
SET WIDTH=WIDTH+WIDTH(1)+2
+45 ;
WRITE ?WIDTH,$PIECE(VADM(3),U,2)
SET WIDTH=WIDTH+WIDTH(2)+2
+46 ;
WRITE ?WIDTH,$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3))
SET WIDTH=WIDTH+WIDTH(3)+2
+47 IF $GET(ADDON)="DENTAL"
WRITE ?WIDTH,$$GET1^DIQ(220,DFN,70.01)
+48 ;
WRITE !
End DoDot:4
+49 ;
+50 ;
IF SORTORDR=3
Begin DoDot:4
+51 ;
SET WIDTH=0
WRITE VADM(1)
SET WIDTH=WIDTH+WIDTH(1)+2
+52 ;
WRITE ?WIDTH,$PIECE(VADM(3),U,2)
SET WIDTH=WIDTH+WIDTH(2)+2
+53 ;
WRITE ?WIDTH,$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3))
SET WIDTH=WIDTH+WIDTH(3)+2
+54 ;
WRITE ?WIDTH,$$FMTDTTM^EHM13UTIL(APPTDTTM)
SET WIDTH=WIDTH+WIDTH(4)+2
+55 ;
WRITE ?WIDTH,$$GET1^DIQ(44,CLINIC,.01)
SET WIDTH=WIDTH+WIDTH(5)+2
+56 IF $GET(ADDON)="DENTAL"
WRITE ?WIDTH,$$GET1^DIQ(220,DFN,70.01)
+57 ;
WRITE !
End DoDot:4
+58 ;
+59 ;
SET LINES=LINES+1
SET RECRDCT=RECRDCT+1
End DoDot:3
if QUIT
QUIT
End DoDot:2
if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+60 ;
WRITE !,"TOTAL RECORDS = ",RECRDCT,!
+61 ;
+62 ;
QUIT
+63 ;
APPTLSTC(TITLE,SORTORDR,TYPE) ; Comma-delimited file
+1 ;
+2 ;
NEW SORT1,SORT2,SORT3,APPTDTTM,DFN,CLINIC,SDECIEN,SDECAPPT,PTAPPT,SCAPPT
+3 ;
+4 ;
USE IO
+5 ;
+6 ; Output first row - list of data fields
+7 ;
+8 ;
NEW HDR
SET HDR(1)="Patient"
SET HDR(2)="DOB"
SET HDR(3)="EDIPI"
SET HDR(4)="Appt Date/Time"
SET HDR(5)="Clinic"
+9 ;
IF $GET(TYPE)="DENTAL"
SET HDR(6)="Dental Classification"
+10 ;
+11 ;
IF SORTORDR=1
Begin DoDot:1
+12 ;
IF $GET(TYPE)="DENTAL"
WRITE $$COMMAOUT^EHM13UTIL(6,HDR(4),HDR(1),HDR(2),HDR(3),HDR(5),HDR(6)),!
+13 ;
IF '$TEST
WRITE $$COMMAOUT^EHM13UTIL(5,HDR(4),HDR(1),HDR(2),HDR(3),HDR(5)),!
End DoDot:1
+14 ;
IF SORTORDR=2
Begin DoDot:1
+15 ;
IF $GET(TYPE)="DENTAL"
WRITE $$COMMAOUT^EHM13UTIL(6,HDR(5),HDR(4),HDR(1),HDR(2),HDR(3),HDR(6)),!
+16 ;
IF '$TEST
WRITE $$COMMAOUT^EHM13UTIL(5,HDR(5),HDR(4),HDR(1),HDR(2),HDR(3)),!
End DoDot:1
+17 ;
IF SORTORDR=3
Begin DoDot:1
+18 ;
IF $GET(TYPE)="DENTAL"
WRITE $$COMMAOUT^EHM13UTIL(6,HDR(1),HDR(2),HDR(3),HDR(4),HDR(5),HDR(6)),!
+19 ;
IF '$TEST
WRITE $$COMMAOUT^EHM13UTIL(5,HDR(1),HDR(2),HDR(3),HDR(4),HDR(5)),!
End DoDot:1
+20 ;
+21 ; Scan sorted data in ^TMP($J)
+22 ;
+23 ;
SET SORT1=""
FOR
SET SORT1=$ORDER(^TMP($JOB,SORT1))
if SORT1=""
QUIT
Begin DoDot:1
+24 ;
SET SORT2=""
FOR
SET SORT2=$ORDER(^TMP($JOB,SORT1,SORT2))
if SORT2=""
QUIT
Begin DoDot:2
+25 ;
SET SORT3=""
FOR
SET SORT3=$ORDER(^TMP($JOB,SORT1,SORT2,SORT3))
if SORT3=""
QUIT
Begin DoDot:3
+26 ;
IF SORTORDR=1
SET APPTDTTM=SORT1
SET DFN=$PIECE(SORT2,U,2)
SET CLINIC=$PIECE(SORT3,U,2)
+27 ;
IF SORTORDR=2
SET CLINIC=$PIECE(SORT1,U,2)
SET APPTDTTM=SORT2
SET DFN=$PIECE(SORT3,U,2)
+28 ;
IF SORTORDR=3
SET DFN=$PIECE(SORT1,U,2)
SET APPTDTTM=SORT2
SET CLINIC=$PIECE(SORT3,U,2)
+29 ;
+30 ;
SET SDECAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,409.84))
SET SDECIEN=$PIECE(SDECAPPT,U,1)
SET SDECAPPT=$PIECE(SDECAPPT,U,2,999)
+31 ;
SET PTAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,2))
+32 ;
SET SCAPPT=$GET(^TMP($JOB,SORT1,SORT2,SORT3,44))
+33 ;
KILL VADM
DO DEM^VADPT
+34 ;
+35 ;
IF SORTORDR=1
Begin DoDot:4
+36 ;
IF $GET(TYPE)="DENTAL"
WRITE $$COMMAOUT^EHM13UTIL(6,$$FMTDTTM^EHM13UTIL(APPTDTTM),VADM(1),$PIECE(VADM(3),U,2),$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3)),$$GET1^DIQ(44,CLINIC,.01),$$GET1^DIQ(220,DFN,70.01)),!
+37 ;
IF '$TEST
WRITE $$COMMAOUT^EHM13UTIL(5,$$FMTDTTM^EHM13UTIL(APPTDTTM),VADM(1),$PIECE(VADM(3),U,2),$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3)),$$GET1^DIQ(44,CLINIC,.01)),!
End DoDot:4
+38 ;
IF SORTORDR=2
Begin DoDot:4
+39 ;
IF $GET(TYPE)="DENTAL"
WRITE $$COMMAOUT^EHM13UTIL(6,$$GET1^DIQ(44,CLINIC,.01),$$FMTDTTM^EHM13UTIL(APPTDTTM),VADM(1),$PIECE(VADM(3),U,2),$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3)),$$GET1^DIQ(220,DFN,70.01)),!
+40 ;
IF '$TEST
WRITE $$COMMAOUT^EHM13UTIL(5,$$GET1^DIQ(44,CLINIC,.01),$$FMTDTTM^EHM13UTIL(APPTDTTM),VADM(1),$PIECE(VADM(3),U,2),$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3))),!
End DoDot:4
+41 ;
IF SORTORDR=3
Begin DoDot:4
+42 ;
IF $GET(TYPE)="DENTAL"
WRITE $$COMMAOUT^EHM13UTIL(6,VADM(1),$PIECE(VADM(3),U,2),$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3)),$$FMTDTTM^EHM13UTIL(APPTDTTM),$$GET1^DIQ(44,CLINIC,.01),$$GET1^DIQ(220,DFN,70.01)),!
+43 ;
IF '$TEST
WRITE $$COMMAOUT^EHM13UTIL(5,VADM(1),$PIECE(VADM(3),U,2),$$EDIPI(DFN,$PIECE($$SITE^VASITE(),U,3)),$$FMTDTTM^EHM13UTIL(APPTDTTM),$$GET1^DIQ(44,CLINIC,.01)),!
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+44 ;
+45 ;
QUIT
+46 ;
+1 ;
+2 ; TITLE = Report title
+3 ; CONVDATE = Conversion date (FM format)
+4 ; SORTORDR = Sort order (1,2,3)
+5 ; TYPE (see POSTLIST)
+6 ; FILTER = "A" if all clinics selected, "S^ien in #44" if single clinic selected, "C^ien in #40.7 if single stop code selected.
+7 ;
+8 ;
WRITE @IOF,$$CENTER^EHM13UTIL(TITLE_" - Station "_$PIECE($$SITE^VASITE(),U,3),$GET(IOM,80)),!
+9 ;
IF $PIECE($GET(FILTER),U,1)="S"
WRITE $$CENTER^EHM13UTIL("CLINIC: "_$$GET1^DIQ(44,$PIECE(FILTER,U,2),.01),$GET(IOM,80)),!
+10 ;
IF $PIECE($GET(FILTER),U,1)="C"
WRITE $$CENTER^EHM13UTIL("STOP CODE: "_$$GET1^DIQ(40.7,$PIECE(FILTER,U,2),.01),$GET(IOM,80)),!
+11 ;
if $GET(CONVDATE)'=""
WRITE $$CENTER^EHM13UTIL("Conversion Date: "_$$FMTE^XLFDT(CONVDATE),$GET(IOM,80)),!
WRITE !
+12 ;
+13 ;
NEW HDR
SET HDR(1)="Patient"
SET HDR(2)="DOB"
SET HDR(3)="EDIPI"
SET HDR(4)="Appt Date/Time"
SET HDR(5)="Clinic"
+14 ;
NEW WIDTH
SET WIDTH(1)=30
SET WIDTH(2)=11
SET WIDTH(3)=30
SET WIDTH(4)=14
SET WIDTH(5)=30
+15 ;
+16 ;
IF $GET(TYPE)="DENTAL"
SET HDR(6)="Dental Classification"
SET WIDTH(6)=50
+17 ;
+18 ;
NEW IDX
+19 ;
IF SORTORDR=1
Begin DoDot:1
+20 ;
SET WIDTH=0
+21 ;
FOR IDX=4,1,2,3,5,$SELECT($GET(TYPE)'="":6,1:"")
IF IDX
WRITE ?WIDTH,HDR(IDX)
SET WIDTH=WIDTH+WIDTH(IDX)+2
+22 ;
WRITE !
+23 ;
SET WIDTH=0
+24 ;
FOR IDX=4,1,2,3,5,$SELECT($GET(TYPE)'="":6,1:"")
IF IDX
WRITE ?WIDTH,$$DASHES^EHM13UTIL(WIDTH(IDX))
SET WIDTH=WIDTH+WIDTH(IDX)+2
+25 ;
WRITE !
End DoDot:1
+26 ;
+27 ;
IF SORTORDR=2
Begin DoDot:1
+28 ;
SET WIDTH=0
+29 ;
FOR IDX=5,4,1,2,3,$SELECT($GET(TYPE)'="":6,1:"")
IF IDX
WRITE ?WIDTH,HDR(IDX)
SET WIDTH=WIDTH+WIDTH(IDX)+2
+30 ;
WRITE !
+31 ;
SET WIDTH=0
+32 ;
FOR IDX=5,4,1,2,3,$SELECT($GET(TYPE)'="":6,1:"")
IF IDX
WRITE ?WIDTH,$$DASHES^EHM13UTIL(WIDTH(IDX))
SET WIDTH=WIDTH+WIDTH(IDX)+2
+33 ;
WRITE !
End DoDot:1
+34 ;
+35 ;
IF SORTORDR=3
Begin DoDot:1
+36 ;
SET WIDTH=0
+37 ;
FOR IDX=1,2,3,4,5,$SELECT($GET(TYPE)'="":6,1:"")
IF IDX
WRITE ?WIDTH,HDR(IDX)
SET WIDTH=WIDTH+WIDTH(IDX)+2
+38 ;
WRITE !
+39 ;
SET WIDTH=0
+40 ;
FOR IDX=1,2,3,4,5,$SELECT($GET(TYPE)'="":6,1:"")
IF IDX
WRITE ?WIDTH,$$DASHES^EHM13UTIL(WIDTH(IDX))
SET WIDTH=WIDTH+WIDTH(IDX)+2
+41 ;
WRITE !
End DoDot:1
+42 ;
+43 ;
QUIT
+44 ;
EDIPI(DFN,SITE) ;
+1 ;
+2 ; Return patient's EDIPI
+3 ;
+4 ;
NEW TFLIST,I,EDIPI
+5 ;
+6 ; icr #4648
DO TFL^VAFCTFU2(.TFLIST,DFN_U_"PI"_U_"USVHA"_U_SITE)
+7 ;
+8 ;
SET EDIPI=""
FOR I=1:1
if '$DATA(TFLIST(I))
QUIT
IF $PIECE(TFLIST(I),U,2)="NI"
IF $PIECE(TFLIST(I),U,3)="USDOD"
IF $PIECE(TFLIST(I),U,4)="200DOD"
IF $PIECE(TFLIST(I),U,5)="A"
SET EDIPI=$PIECE(TFLIST(I),U,1)
QUIT
+9 ;
+10 ;
QUIT EDIPI
+11 ;
