ECXUCBOC ;ALB/TJL-CBOC Activity Report ;8/6/24 12:08
;;3.0;DSS EXTRACTS;**49,148,149,160,166,190**;Dec 22, 1997;Build 36
;
EN ; entry point
N X,Y,DATE,PG,COUNT,ECRUN,ECXDESC,ECXSAVE,ECXTL,YYYYMM,ECXJOB
N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXPORT,CNT ;149
S (QFLG,COUNT,PG)=0
; get today's date
D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
;D BEGIN Q:QFLG
D SELECT Q:QFLG
S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I $G(ECXPORT) D Q ;149 Section added
.S CNT=1
.D PROCESS
.S ^TMP($J,"ECXPORT",0)="FEEDER KEY^DIVISION^CLINIC^PATIENT NAME^SSN^VISIT DATE/TIME"
.D EXPDISP^ECXUTL1
.D AUDIT^ECXKILL
S ECXDESC="CBOC Activity Report"
S ECXSAVE("EC*")=""
W !!,"This report requires 80-column format."
D EN^XUTMDEVQ("PROCESS^ECXUCBOC",ECXDESC,.ECXSAVE)
I POP W !!,"No device selected...exiting.",! Q
I IO'=IO(0) D ^%ZISC
D HOME^%ZIS
D AUDIT^ECXKILL
Q
;
BEGIN ; display report description
W @IOF
W !,"This report prints a listing of all Clinical (CLI) records"
W !,"that have a Community Based Outpatient Clinic (CBOC) status of"
W !,"Y (=Yes). Reports are grouped by Feeder Key, Division, and"
W !,"Clinic; detail lines include Patient Name, SSN, and Date of Visit."
W !,"Totals for unique SSNs and unique Dates of Visit will be displayed"
W !,"at the Clinic, Division, Feeder Key, and Report levels."
S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
W:$Y!($E(IOST)="C") @IOF,!!
Q
;
SELECT ; user inputs for start date
N OUT,DONE,LIST,IEN,ECXFROM,ECXEND,ECXRUN,ECXCNT,ECXDIV,LN,HDT ;149
W @IOF
S (PG,QFLG)=0,$P(LN,"-",80)=""
D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D LISTHDR
S IEN=0 F S IEN=$O(^ECX(727,IEN)) Q:IEN="" Q:QFLG D:$Y+4>IOSL LISTHDR Q:QFLG I $G(^ECX(727,IEN,"HEAD"))="CLI" D
.I $G(^ECX(727,IEN,"PURG")) Q
.I '$D(^ECX(727,IEN,0)) Q
.I $P(^ECX(727,IEN,0),U,4)<3030101 Q
.S ECXJOB=$P(^ECX(727,IEN,0),U)
.S ECXFROM=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,4),"5DF")," ","0")
.S ECXEND=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,5),"5DF")," ","0")
.S ECXRUN=$TR($$FMTE^XLFDT($P(^ECX(727,IEN,0),U,2),"5DF")," ","0")
.S ECXCNT=$P(^ECX(727,IEN,0),U,6)
.S ECXDIV=$P($G(^ECX(727,IEN,"DIV")),U) I ECXDIV D
..S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
..D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
.D:$Y+3>IOSL LISTHDR Q:QFLG
.W !?4,ECXJOB,?14,ECXRUN,?28,$J(ECXCNT,9),?41,ECXFROM," - ",ECXEND,?71,ECXDIV
.S LIST(ECXJOB)=1
S QFLG=0 ;149 Reset QFLG so choice can be made if user "^" during list
S DIR(0)="NA^"_$O(LIST(0))_":"_$O(LIST(" "),-1)_":0"_"^I '$D(LIST(X)) K X",DIR("A")="Create the CBOC Activity Report for extract number: ",DIR("?")="Select the extract number to use to build the report." ;149
W ! D ^DIR K DIR I $D(DIRUT) K LIST S QFLG=1 Q
I '$D(X) W !!,"Invalid choice. Please try again." S DIR(0)="E" W ! D ^DIR K DIR D Q:QFLG G SELECT ;149
.I 'Y S QFLG=1
S ECXJOB=X
S Y=$P(^ECX(727,ECXJOB,0),U,5) D DD^%DT
S ECSTART=$P(Y," ")_$P(Y,",",2)
Q
;
LISTHDR ;
I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"Selectable Clinic Extracts for CBOC Activity Report",?72,"Page: ",PG
W !!,"Extract #",?15,"Run Date",?28,"Rec Count",?42,"Date Range of Extract",?68,"Division",!,LN
Q
;
PROCESS ; entry point for queued report
N ECXD,QFLG,PG,RECDA,LN,COUNT
N FKEY,DIV,CLIN,SSN,DFN,VDATE,KEY
N TSSN,FSSN,DSSN,CSSN,TVISIT,FVISIT,DVISIT,CVISIT,DLAYGO
N OLDFKEY,OLDDIV,OLDCLIN,OLDSSN,OLDDFN,OLDVDATE,OLDKEY,HEADKEY
S (QFLG,COUNT,PG)=0,ZTREQ="@",ECXD="-",$P(LN,"-",80)=""
K ^TMP($J)
W @IOF
;
; set report created indicator
K DA,DIC,DD,DO
S DA(1)=1
I '$D(^ECX(728,DA(1),"CBOC","B",ECXJOB)) D
.S DLAYGO=728,DIC(0)="L",DIC("P")=$P(^DD(728,68,0),U,2)
.S DIC="^ECX(728,"_DA(1)_",""CBOC"",",X=ECXJOB
.D FILE^DICN
;
I $O(^ECX(727.827,"AC",ECXJOB,0))="" D Q
.I '$G(ECXPORT) W !,"No extract records exist for the selected extract." ;149
S RECDA=0
F S RECDA=$O(^ECX(727.827,"AC",ECXJOB,RECDA)) Q:'RECDA D ISCBOC
;
I '$D(^TMP($J)) W:'$G(ECXPORT) !,"No records were found with a CBOC Indicator value of ""Y""." S QFLG=1 Q ;149
;
S (TSSN,FSSN,DSSN,CSSN,TVISIT,FVISIT,DVISIT,CVISIT)=0
S RECDA=$O(^TMP($J,"AKEY",""))
S HEADKEY=RECDA
I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(RECDA,ECXD)_U_$P(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$P(RECDA,ECXD,3),.01) ;149
D:'$G(ECXPORT) HEADER Q:QFLG D DETAIL Q:QFLG D INCVIS D INCSSN D SETOLD ;149
;
; process all CBOC records
F S RECDA=$O(^TMP($J,"AKEY",RECDA)) Q:RECDA="" D Q:QFLG
.S HEADKEY=OLDKEY
.; key fields match, so print detail record and increment total(s)
.I $P(RECDA,ECXD,1,3)=OLDKEY D Q
..I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(RECDA,ECXD)_U_$P(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$P(RECDA,ECXD,3),.01) ;149
..D DETAIL Q:QFLG
..D INCVIS
..S SSN=$P(RECDA,ECXD,4)
..I '$D(^TMP($J,"C",OLDCLIN,SSN)) D INCSSN S OLDSSN=SSN
.;
.; if fkey changed, print "C","D", and "F" totals
.I $P(RECDA,ECXD)'=OLDFKEY D Q:QFLG
..D CLINTOT Q:QFLG D DIVTOT Q:QFLG D FKEYTOT Q:QFLG
.E D Q:QFLG
..I $P(RECDA,ECXD,2)'=OLDDIV D
...D CLINTOT Q:QFLG D DIVTOT Q:QFLG
..E D CLINTOT Q:QFLG
.;
.; something changed, so print subheader and detail line
.Q:QFLG S HEADKEY=RECDA
.I '$G(ECXPORT) D HEADER2 Q:QFLG ;149
.I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=$P(RECDA,ECXD)_U_$P(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$P(RECDA,ECXD,3),.01) ;149
.D DETAIL Q:QFLG
.D INCVIS
.D INCSSN
.D SETOLD
.Q
Q:QFLG
; print totals for clinic, division, feeder key, and grand totals
S HEADKEY=OLDKEY
D CLINTOT Q:QFLG
D DIVTOT Q:QFLG
D FKEYTOT Q:QFLG
D GTOTAL Q:QFLG
Q
;
ISCBOC ;
I $P(^ECX(727.827,RECDA,2),U,15)="Y" D SETKEY
Q
;
INCVIS ;
S TVISIT=TVISIT+1
S FVISIT=FVISIT+1
S DVISIT=DVISIT+1
S CVISIT=CVISIT+1
Q
;
INCSSN ;
N ZSSN,ZF,ZD,ZC
S ZSSN=$P(RECDA,ECXD,4)
S ZF=$P(RECDA,ECXD,1)
S ZD=$P(RECDA,ECXD,2)
S ZC=$P(RECDA,ECXD,3)
I '$D(^TMP($J,"SSN",ZSSN)) S ^TMP($J,"SSN",ZSSN)="" S TSSN=TSSN+1
I '$D(^TMP($J,"F",ZF,ZSSN)) S ^TMP($J,"F",ZF,ZSSN)="" S FSSN=FSSN+1
I '$D(^TMP($J,"D",ZD,ZSSN)) S ^TMP($J,"D",ZD,ZSSN)="" S DSSN=DSSN+1
I '$D(^TMP($J,"C",ZC,ZSSN)) S ^TMP($J,"C",ZC,ZSSN)="" S CSSN=CSSN+1
Q
;
SETOLD ;
S OLDKEY=$P(RECDA,ECXD,1,3)
S OLDFKEY=$P(RECDA,ECXD)
S OLDDIV=$P(RECDA,ECXD,2)
S OLDCLIN=$P(RECDA,ECXD,3)
S OLDSSN=$P(RECDA,ECXD,4)
Q
;
SETKEY ;
N CLIN,DIV,FKEY,DFN,SSN,VDATE
S CLIN=$P(^ECX(727.827,RECDA,0),U,12) I '+CLIN S CLIN=$P(^ECX(727.827,RECDA,4),U,9) ;160 If clinic info not in old location get it from the new location
S DIV=$P(^ECX(727.827,RECDA,2),U,8)
S FKEY=$P(^ECX(727.827,RECDA,0),U,10) I '+FKEY S FKEY=$P($G(^ECX(727.827,RECDA,4)),U,10) ;166 Get feeder key from old location, if nothing there, get it from new location
S DFN=$P(^ECX(727.827,RECDA,0),U,5)
S SSN=$P(^ECX(727.827,RECDA,0),U,6)
S VDATE=$P(^ECX(727.827,RECDA,0),U,9)_"."_$P(^ECX(727.827,RECDA,0),U,14)
S KEY=FKEY_ECXD_DIV_ECXD_CLIN_ECXD_SSN_ECXD_DFN_ECXD_VDATE
S ^TMP($J,"AKEY",KEY)=""
Q
;
DETAIL ; print detail line
N DFN,PTNAME,DISPDT,DISPTM
U IO
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
S COUNT=COUNT+1
;S QFLG=0
I '$G(ECXPORT) I $Y+3>IOSL D HEADER Q:QFLG ;149
; get patient name using DFN
S DFN=$P(RECDA,ECXD,5)
S PTNAME=$S(DFN'="":$P(^DPT(DFN,0),U),1:"")
S DISPDT=$P(RECDA,ECXD,6)
S DISPTM=$E(DISPDT,9,14)
S DISPDT=$E(DISPDT,1,4)-1700_$E(DISPDT,5,8)
S DISPDT=DISPDT_DISPTM
I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=^TMP($J,"ECXPORT",CNT)_U_PTNAME_U_$P(RECDA,ECXD,4)_U_$$FMTE^XLFDT(DISPDT,1),CNT=CNT+1 Q ;149
W !,PTNAME,?36,$P(RECDA,ECXD,4),?51,$$FMTE^XLFDT(DISPDT,1)
Q
;
CLINTOT ;
S COUNT=COUNT+2
I '$G(ECXPORT) I $Y+3>IOSL D HEADER Q:QFLG ;149
I '$G(ECXPORT) W !!,?5,"Total Unique SSNs for Clinic:" ;149
I '$G(ECXPORT) W ?35,$J(CSSN,10),?50,$J(CVISIT,10),?61,"Clinic Visits" ;149
I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^",CNT=CNT+1 S ^TMP($J,"ECXPORT",CNT)="^^^Total Unique SSNs for Clinic"_U_CSSN_U_"Clinic Visits"_U_CVISIT,CNT=CNT+1 ;149
S (CSSN,CVISIT)=0 S OLDCLIN=$P(RECDA,ECXD,3) K ^TMP($J,"C")
Q
;
DIVTOT ;
S COUNT=COUNT+1
I '$G(ECXPORT) I $Y+3>IOSL D HEADER Q:QFLG ;149
I '$G(ECXPORT) W !,?3,"Total Unique SSNs for Division:" ;149
I '$G(ECXPORT) W ?35,$J(DSSN,10),?50,$J(DVISIT,10),?61,"Division Visits" ;149
I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^^Total Unique SSNs for Division"_U_DSSN_U_"Division Visits"_U_DVISIT,CNT=CNT+1 ;149
S (DSSN,DVISIT)=0 S OLDDIV=$P(RECDA,ECXD,2) K ^TMP($J,"D")
Q
;
FKEYTOT ;
S COUNT=COUNT+1
I '$G(ECXPORT) I $Y+3>IOSL D HEADER Q:QFLG ;149
I '$G(ECXPORT) W !,?1,"Total Unique SSNs for Feeder Key:" ;149
I '$G(ECXPORT) W ?35,$J(FSSN,10),?50,$J(FVISIT,10),?61,"Feeder Key Visits" ;149
I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^^Total Unique SSNs for Feeder Key"_U_FSSN_U_"Feeder Key Visits"_U_FVISIT,CNT=CNT+1,^TMP($J,"ECXPORT",CNT)="^",CNT=CNT+1 ;149
S (FSSN,FVISIT)=0 S OLDFKEY=$P(RECDA,ECXD) K ^TMP($J,"F")
Q
;
GTOTAL ;
S COUNT=COUNT+1
I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)="^^^Total Unique SSNs (entire report)"_U_TSSN_U_"Total Visits"_U_TVISIT Q ;149
I $Y+3>IOSL D HEADER Q:QFLG
W !,"Total Unique SSNs (entire report):"
W ?35,$J(TSSN,10),?50,$J(TVISIT,10),?61,"Total Visits"
Q
;
CLOSE ;
I $E(IOST)="C",'QFLG D
.S SS=22-$Y F JJ=1:1:SS W !
.S DIR(0)="E" W ! D ^DIR K DIR
Q
;
D HEADER1 Q:QFLG
D HEADER2 Q:QFLG
Q
N SS,JJ
I $E(IOST)="C" D
.S SS=22-$Y F JJ=1:1:SS W !
.I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
Q:QFLG
W:$Y!($E(IOST)="C") @IOF S PG=PG+1
W !,"CBOC Activity Report"
W ?(73-$L(PG)),"Page: "_PG
W !,ECSTART,?50,"Report Run Date: "_ECRUN
Q
;
I $Y+8>IOSL D HEADER1 Q:QFLG
N CLINIC
S CLINIC=$$GET1^DIQ(44,$P($P(HEADKEY,ECXD,3),U),.01,)
W !!,"Feeder Key: ",$P(HEADKEY,ECXD)
W ?31,"Division: ",$P(HEADKEY,ECXD,2)
W ?51,"Clinic: ",$E(CLINIC,1,20)
W !!,"Patient",?39,"SSN",?51,"Visit Date/Time"
W !,LN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXUCBOC 10249 printed Sep 23, 2025@19:30:16 Page 2
ECXUCBOC ;ALB/TJL-CBOC Activity Report ;8/6/24 12:08
+1 ;;3.0;DSS EXTRACTS;**49,148,149,160,166,190**;Dec 22, 1997;Build 36
+2 ;
EN ; entry point
+1 NEW X,Y,DATE,PG,COUNT,ECRUN,ECXDESC,ECXSAVE,ECXTL,YYYYMM,ECXJOB
+2 ;149
NEW ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXPORT,CNT
+3 SET (QFLG,COUNT,PG)=0
+4 ; get today's date
+5 DO NOW^%DTC
SET DATE=X
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET ECRUN=$PIECE(Y,"@")
KILL %DT
+6 ;D BEGIN Q:QFLG
+7 DO SELECT
if QFLG
QUIT
+8 ;149 Section added
SET ECXPORT=$$EXPORT^ECXUTL1
if ECXPORT=-1
QUIT
IF $GET(ECXPORT)
Begin DoDot:1
+9 SET CNT=1
+10 DO PROCESS
+11 SET ^TMP($JOB,"ECXPORT",0)="FEEDER KEY^DIVISION^CLINIC^PATIENT NAME^SSN^VISIT DATE/TIME"
+12 DO EXPDISP^ECXUTL1
+13 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+14 SET ECXDESC="CBOC Activity Report"
+15 SET ECXSAVE("EC*")=""
+16 WRITE !!,"This report requires 80-column format."
+17 DO EN^XUTMDEVQ("PROCESS^ECXUCBOC",ECXDESC,.ECXSAVE)
+18 IF POP
WRITE !!,"No device selected...exiting.",!
QUIT
+19 IF IO'=IO(0)
DO ^%ZISC
+20 DO HOME^%ZIS
+21 DO AUDIT^ECXKILL
+22 QUIT
+23 ;
BEGIN ; display report description
+1 WRITE @IOF
+2 WRITE !,"This report prints a listing of all Clinical (CLI) records"
+3 WRITE !,"that have a Community Based Outpatient Clinic (CBOC) status of"
+4 WRITE !,"Y (=Yes). Reports are grouped by Feeder Key, Division, and"
+5 WRITE !,"Clinic; detail lines include Patient Name, SSN, and Date of Visit."
+6 WRITE !,"Totals for unique SSNs and unique Dates of Visit will be displayed"
+7 WRITE !,"at the Clinic, Division, Feeder Key, and Report levels."
+8 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
QUIT
+9 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF,!!
+10 QUIT
+11 ;
SELECT ; user inputs for start date
+1 ;149
NEW OUT,DONE,LIST,IEN,ECXFROM,ECXEND,ECXRUN,ECXCNT,ECXDIV,LN,HDT
+2 WRITE @IOF
+3 SET (PG,QFLG)=0
SET $PIECE(LN,"-",80)=""
+4 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET HDT=Y
DO LISTHDR
+5 SET IEN=0
FOR
SET IEN=$ORDER(^ECX(727,IEN))
if IEN=""
QUIT
if QFLG
QUIT
if $Y+4>IOSL
DO LISTHDR
if QFLG
QUIT
IF $GET(^ECX(727,IEN,"HEAD"))="CLI"
Begin DoDot:1
+6 IF $GET(^ECX(727,IEN,"PURG"))
QUIT
+7 IF '$DATA(^ECX(727,IEN,0))
QUIT
+8 IF $PIECE(^ECX(727,IEN,0),U,4)<3030101
QUIT
+9 SET ECXJOB=$PIECE(^ECX(727,IEN,0),U)
+10 SET ECXFROM=$TRANSLATE($$FMTE^XLFDT($PIECE(^ECX(727,IEN,0),U,4),"5DF")," ","0")
+11 SET ECXEND=$TRANSLATE($$FMTE^XLFDT($PIECE(^ECX(727,IEN,0),U,5),"5DF")," ","0")
+12 SET ECXRUN=$TRANSLATE($$FMTE^XLFDT($PIECE(^ECX(727,IEN,0),U,2),"5DF")," ","0")
+13 SET ECXCNT=$PIECE(^ECX(727,IEN,0),U,6)
+14 SET ECXDIV=$PIECE($GET(^ECX(727,IEN,"DIV")),U)
IF ECXDIV
Begin DoDot:2
+15 SET DA=ECXDIV
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+16 DO EN^DIQ1
SET ECXDIV=$GET(ECXDIC(4,DA,99,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
End DoDot:2
+17 if $Y+3>IOSL
DO LISTHDR
if QFLG
QUIT
+18 WRITE !?4,ECXJOB,?14,ECXRUN,?28,$JUSTIFY(ECXCNT,9),?41,ECXFROM," - ",ECXEND,?71,ECXDIV
+19 SET LIST(ECXJOB)=1
End DoDot:1
+20 ;149 Reset QFLG so choice can be made if user "^" during list
SET QFLG=0
+21 ;149
SET DIR(0)="NA^"_$ORDER(LIST(0))_":"_$ORDER(LIST(" "),-1)_":0"_"^I '$D(LIST(X)) K X"
SET DIR("A")="Create the CBOC Activity Report for extract number: "
SET DIR("?")="Select the extract number to use to build the report."
+22 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL LIST
SET QFLG=1
QUIT
+23 ;149
IF '$DATA(X)
WRITE !!,"Invalid choice. Please try again."
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
Begin DoDot:1
+24 IF 'Y
SET QFLG=1
End DoDot:1
if QFLG
QUIT
GOTO SELECT
+25 SET ECXJOB=X
+26 SET Y=$PIECE(^ECX(727,ECXJOB,0),U,5)
DO DD^%DT
+27 SET ECSTART=$PIECE(Y," ")_$PIECE(Y,",",2)
+28 QUIT
+29 ;
LISTHDR ;
+1 IF $EXTRACT(IOST)="C"
SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+2 IF $EXTRACT(IOST)="C"
IF PG>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
QUIT
+3 SET PG=PG+1
if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
WRITE !,"Selectable Clinic Extracts for CBOC Activity Report",?72,"Page: ",PG
+4 WRITE !!,"Extract #",?15,"Run Date",?28,"Rec Count",?42,"Date Range of Extract",?68,"Division",!,LN
+5 QUIT
+6 ;
PROCESS ; entry point for queued report
+1 NEW ECXD,QFLG,PG,RECDA,LN,COUNT
+2 NEW FKEY,DIV,CLIN,SSN,DFN,VDATE,KEY
+3 NEW TSSN,FSSN,DSSN,CSSN,TVISIT,FVISIT,DVISIT,CVISIT,DLAYGO
+4 NEW OLDFKEY,OLDDIV,OLDCLIN,OLDSSN,OLDDFN,OLDVDATE,OLDKEY,HEADKEY
+5 SET (QFLG,COUNT,PG)=0
SET ZTREQ="@"
SET ECXD="-"
SET $PIECE(LN,"-",80)=""
+6 KILL ^TMP($JOB)
+7 WRITE @IOF
+8 ;
+9 ; set report created indicator
+10 KILL DA,DIC,DD,DO
+11 SET DA(1)=1
+12 IF '$DATA(^ECX(728,DA(1),"CBOC","B",ECXJOB))
Begin DoDot:1
+13 SET DLAYGO=728
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(728,68,0),U,2)
+14 SET DIC="^ECX(728,"_DA(1)_",""CBOC"","
SET X=ECXJOB
+15 DO FILE^DICN
End DoDot:1
+16 ;
+17 IF $ORDER(^ECX(727.827,"AC",ECXJOB,0))=""
Begin DoDot:1
+18 ;149
IF '$GET(ECXPORT)
WRITE !,"No extract records exist for the selected extract."
End DoDot:1
QUIT
+19 SET RECDA=0
+20 FOR
SET RECDA=$ORDER(^ECX(727.827,"AC",ECXJOB,RECDA))
if 'RECDA
QUIT
DO ISCBOC
+21 ;
+22 ;149
IF '$DATA(^TMP($JOB))
if '$GET(ECXPORT)
WRITE !,"No records were found with a CBOC Indicator value of ""Y""."
SET QFLG=1
QUIT
+23 ;
+24 SET (TSSN,FSSN,DSSN,CSSN,TVISIT,FVISIT,DVISIT,CVISIT)=0
+25 SET RECDA=$ORDER(^TMP($JOB,"AKEY",""))
+26 SET HEADKEY=RECDA
+27 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)=$PIECE(RECDA,ECXD)_U_$PIECE(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$PIECE(RECDA,ECXD,3),.01)
+28 ;149
if '$GET(ECXPORT)
DO HEADER
if QFLG
QUIT
DO DETAIL
if QFLG
QUIT
DO INCVIS
DO INCSSN
DO SETOLD
+29 ;
+30 ; process all CBOC records
+31 FOR
SET RECDA=$ORDER(^TMP($JOB,"AKEY",RECDA))
if RECDA=""
QUIT
Begin DoDot:1
+32 SET HEADKEY=OLDKEY
+33 ; key fields match, so print detail record and increment total(s)
+34 IF $PIECE(RECDA,ECXD,1,3)=OLDKEY
Begin DoDot:2
+35 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)=$PIECE(RECDA,ECXD)_U_$PIECE(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$PIECE(RECDA,ECXD,3),.01)
+36 DO DETAIL
if QFLG
QUIT
+37 DO INCVIS
+38 SET SSN=$PIECE(RECDA,ECXD,4)
+39 IF '$DATA(^TMP($JOB,"C",OLDCLIN,SSN))
DO INCSSN
SET OLDSSN=SSN
End DoDot:2
QUIT
+40 ;
+41 ; if fkey changed, print "C","D", and "F" totals
+42 IF $PIECE(RECDA,ECXD)'=OLDFKEY
Begin DoDot:2
+43 DO CLINTOT
if QFLG
QUIT
DO DIVTOT
if QFLG
QUIT
DO FKEYTOT
if QFLG
QUIT
End DoDot:2
if QFLG
QUIT
+44 IF '$TEST
Begin DoDot:2
+45 IF $PIECE(RECDA,ECXD,2)'=OLDDIV
Begin DoDot:3
+46 DO CLINTOT
if QFLG
QUIT
DO DIVTOT
if QFLG
QUIT
End DoDot:3
+47 IF '$TEST
DO CLINTOT
if QFLG
QUIT
End DoDot:2
if QFLG
QUIT
+48 ;
+49 ; something changed, so print subheader and detail line
+50 if QFLG
QUIT
SET HEADKEY=RECDA
+51 ;149
IF '$GET(ECXPORT)
DO HEADER2
if QFLG
QUIT
+52 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)=$PIECE(RECDA,ECXD)_U_$PIECE(RECDA,ECXD,2)_U_$$GET1^DIQ(44,$PIECE(RECDA,ECXD,3),.01)
+53 DO DETAIL
if QFLG
QUIT
+54 DO INCVIS
+55 DO INCSSN
+56 DO SETOLD
+57 QUIT
End DoDot:1
if QFLG
QUIT
+58 if QFLG
QUIT
+59 ; print totals for clinic, division, feeder key, and grand totals
+60 SET HEADKEY=OLDKEY
+61 DO CLINTOT
if QFLG
QUIT
+62 DO DIVTOT
if QFLG
QUIT
+63 DO FKEYTOT
if QFLG
QUIT
+64 DO GTOTAL
if QFLG
QUIT
+65 QUIT
+66 ;
ISCBOC ;
+1 IF $PIECE(^ECX(727.827,RECDA,2),U,15)="Y"
DO SETKEY
+2 QUIT
+3 ;
INCVIS ;
+1 SET TVISIT=TVISIT+1
+2 SET FVISIT=FVISIT+1
+3 SET DVISIT=DVISIT+1
+4 SET CVISIT=CVISIT+1
+5 QUIT
+6 ;
INCSSN ;
+1 NEW ZSSN,ZF,ZD,ZC
+2 SET ZSSN=$PIECE(RECDA,ECXD,4)
+3 SET ZF=$PIECE(RECDA,ECXD,1)
+4 SET ZD=$PIECE(RECDA,ECXD,2)
+5 SET ZC=$PIECE(RECDA,ECXD,3)
+6 IF '$DATA(^TMP($JOB,"SSN",ZSSN))
SET ^TMP($JOB,"SSN",ZSSN)=""
SET TSSN=TSSN+1
+7 IF '$DATA(^TMP($JOB,"F",ZF,ZSSN))
SET ^TMP($JOB,"F",ZF,ZSSN)=""
SET FSSN=FSSN+1
+8 IF '$DATA(^TMP($JOB,"D",ZD,ZSSN))
SET ^TMP($JOB,"D",ZD,ZSSN)=""
SET DSSN=DSSN+1
+9 IF '$DATA(^TMP($JOB,"C",ZC,ZSSN))
SET ^TMP($JOB,"C",ZC,ZSSN)=""
SET CSSN=CSSN+1
+10 QUIT
+11 ;
SETOLD ;
+1 SET OLDKEY=$PIECE(RECDA,ECXD,1,3)
+2 SET OLDFKEY=$PIECE(RECDA,ECXD)
+3 SET OLDDIV=$PIECE(RECDA,ECXD,2)
+4 SET OLDCLIN=$PIECE(RECDA,ECXD,3)
+5 SET OLDSSN=$PIECE(RECDA,ECXD,4)
+6 QUIT
+7 ;
SETKEY ;
+1 NEW CLIN,DIV,FKEY,DFN,SSN,VDATE
+2 ;160 If clinic info not in old location get it from the new location
SET CLIN=$PIECE(^ECX(727.827,RECDA,0),U,12)
IF '+CLIN
SET CLIN=$PIECE(^ECX(727.827,RECDA,4),U,9)
+3 SET DIV=$PIECE(^ECX(727.827,RECDA,2),U,8)
+4 ;166 Get feeder key from old location, if nothing there, get it from new location
SET FKEY=$PIECE(^ECX(727.827,RECDA,0),U,10)
IF '+FKEY
SET FKEY=$PIECE($GET(^ECX(727.827,RECDA,4)),U,10)
+5 SET DFN=$PIECE(^ECX(727.827,RECDA,0),U,5)
+6 SET SSN=$PIECE(^ECX(727.827,RECDA,0),U,6)
+7 SET VDATE=$PIECE(^ECX(727.827,RECDA,0),U,9)_"."_$PIECE(^ECX(727.827,RECDA,0),U,14)
+8 SET KEY=FKEY_ECXD_DIV_ECXD_CLIN_ECXD_SSN_ECXD_DFN_ECXD_VDATE
+9 SET ^TMP($JOB,"AKEY",KEY)=""
+10 QUIT
+11 ;
DETAIL ; print detail line
+1 NEW DFN,PTNAME,DISPDT,DISPTM
+2 USE IO
+3 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
QUIT
+4 SET COUNT=COUNT+1
+5 ;S QFLG=0
+6 ;149
IF '$GET(ECXPORT)
IF $Y+3>IOSL
DO HEADER
if QFLG
QUIT
+7 ; get patient name using DFN
+8 SET DFN=$PIECE(RECDA,ECXD,5)
+9 SET PTNAME=$SELECT(DFN'="":$PIECE(^DPT(DFN,0),U),1:"")
+10 SET DISPDT=$PIECE(RECDA,ECXD,6)
+11 SET DISPTM=$EXTRACT(DISPDT,9,14)
+12 SET DISPDT=$EXTRACT(DISPDT,1,4)-1700_$EXTRACT(DISPDT,5,8)
+13 SET DISPDT=DISPDT_DISPTM
+14 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)=^TMP($JOB,"ECXPORT",CNT)_U_PTNAME_U_$PIECE(RECDA,ECXD,4)_U_$$FMTE^XLFDT(DISPDT,1)
SET CNT=CNT+1
QUIT
+15 WRITE !,PTNAME,?36,$PIECE(RECDA,ECXD,4),?51,$$FMTE^XLFDT(DISPDT,1)
+16 QUIT
+17 ;
CLINTOT ;
+1 SET COUNT=COUNT+2
+2 ;149
IF '$GET(ECXPORT)
IF $Y+3>IOSL
DO HEADER
if QFLG
QUIT
+3 ;149
IF '$GET(ECXPORT)
WRITE !!,?5,"Total Unique SSNs for Clinic:"
+4 ;149
IF '$GET(ECXPORT)
WRITE ?35,$JUSTIFY(CSSN,10),?50,$JUSTIFY(CVISIT,10),?61,"Clinic Visits"
+5 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)="^"
SET CNT=CNT+1
SET ^TMP($JOB,"ECXPORT",CNT)="^^^Total Unique SSNs for Clinic"_U_CSSN_U_"Clinic Visits"_U_CVISIT
SET CNT=CNT+1
+6 SET (CSSN,CVISIT)=0
SET OLDCLIN=$PIECE(RECDA,ECXD,3)
KILL ^TMP($JOB,"C")
+7 QUIT
+8 ;
DIVTOT ;
+1 SET COUNT=COUNT+1
+2 ;149
IF '$GET(ECXPORT)
IF $Y+3>IOSL
DO HEADER
if QFLG
QUIT
+3 ;149
IF '$GET(ECXPORT)
WRITE !,?3,"Total Unique SSNs for Division:"
+4 ;149
IF '$GET(ECXPORT)
WRITE ?35,$JUSTIFY(DSSN,10),?50,$JUSTIFY(DVISIT,10),?61,"Division Visits"
+5 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)="^^^Total Unique SSNs for Division"_U_DSSN_U_"Division Visits"_U_DVISIT
SET CNT=CNT+1
+6 SET (DSSN,DVISIT)=0
SET OLDDIV=$PIECE(RECDA,ECXD,2)
KILL ^TMP($JOB,"D")
+7 QUIT
+8 ;
FKEYTOT ;
+1 SET COUNT=COUNT+1
+2 ;149
IF '$GET(ECXPORT)
IF $Y+3>IOSL
DO HEADER
if QFLG
QUIT
+3 ;149
IF '$GET(ECXPORT)
WRITE !,?1,"Total Unique SSNs for Feeder Key:"
+4 ;149
IF '$GET(ECXPORT)
WRITE ?35,$JUSTIFY(FSSN,10),?50,$JUSTIFY(FVISIT,10),?61,"Feeder Key Visits"
+5 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)="^^^Total Unique SSNs for Feeder Key"_U_FSSN_U_"Feeder Key Visits"_U_FVISIT
SET CNT=CNT+1
SET ^TMP($JOB,"ECXPORT",CNT)="^"
SET CNT=CNT+1
+6 SET (FSSN,FVISIT)=0
SET OLDFKEY=$PIECE(RECDA,ECXD)
KILL ^TMP($JOB,"F")
+7 QUIT
+8 ;
GTOTAL ;
+1 SET COUNT=COUNT+1
+2 ;149
IF $GET(ECXPORT)
SET ^TMP($JOB,"ECXPORT",CNT)="^^^Total Unique SSNs (entire report)"_U_TSSN_U_"Total Visits"_U_TVISIT
QUIT
+3 IF $Y+3>IOSL
DO HEADER
if QFLG
QUIT
+4 WRITE !,"Total Unique SSNs (entire report):"
+5 WRITE ?35,$JUSTIFY(TSSN,10),?50,$JUSTIFY(TVISIT,10),?61,"Total Visits"
+6 QUIT
+7 ;
CLOSE ;
+1 IF $EXTRACT(IOST)="C"
IF 'QFLG
Begin DoDot:1
+2 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
+4 QUIT
+5 ;
+1 DO HEADER1
if QFLG
QUIT
+2 DO HEADER2
if QFLG
QUIT
+3 QUIT
+1 NEW SS,JJ
+2 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+4 IF PG>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:1
+5 if QFLG
QUIT
+6 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
SET PG=PG+1
+7 WRITE !,"CBOC Activity Report"
+8 WRITE ?(73-$LENGTH(PG)),"Page: "_PG
+9 WRITE !,ECSTART,?50,"Report Run Date: "_ECRUN
+10 QUIT
+11 ;
+1 IF $Y+8>IOSL
DO HEADER1
if QFLG
QUIT
+2 NEW CLINIC
+3 SET CLINIC=$$GET1^DIQ(44,$PIECE($PIECE(HEADKEY,ECXD,3),U),.01,)
+4 WRITE !!,"Feeder Key: ",$PIECE(HEADKEY,ECXD)
+5 WRITE ?31,"Division: ",$PIECE(HEADKEY,ECXD,2)
+6 WRITE ?51,"Clinic: ",$EXTRACT(CLINIC,1,20)
+7 WRITE !!,"Patient",?39,"SSN",?51,"Visit Date/Time"
+8 WRITE !,LN
+9 QUIT
