ECXDRG ;ALB/TJL - DRG Report ;4/2/24 15:12
;;3.0;DSS EXTRACTS;**190**;Dec 22, 1997;Build 36
;
EN ; Entry point from menu option
N I,X,Y,DIR,ECXPORT
;S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ; The output can only be exported,
S ECXPORT=1 D Q ; but code to send output to the screen is retained - tjl FY25 - 190
. K ^TMP($J,"ECXPORT")
. S ^TMP($J,"ECXPORT",0)="DRG^EFFECTIVE DATE^STATUS^INACTIVE DATE^DRG DESCRIPTION"
. D EN1
. M ^TMP($J,"ECXPORT")=^TMP("ECXDRG",$J)
. D EXPDISP^ECXUTL1
;
; Queue Report
W !!,"** Report requires 132 columns to print correctly **",!!
N ZTDESC,ZTIO,ZTSAVE
S ZTIO=""
S ZTDESC="Diagnosis Related Group"
F I="NAME","EFF DATE","STATUS","INACT DATE" D
. S ZTSAVE(I)=""
D EN^XUTMDEVQ("EN1^ECXDRG",ZTDESC,.ZTSAVE)
Q
EN1 ; Tasked entry point
; Declare variables
N U,DA,LN,DESC,NAME,STAT,INACT,LINEDA,LINECT,NODE0,PAGENUM,NESI
N DIC,DR,DIQ,CNT,STOP,QFLG,RUNDATE
K ^TMP("ECXDRG",$J)
S U="^",$P(LN,"-",132)=""
S (CNT,QFLG,PAGENUM,STOP)=0
D NOW^%DTC S Y=$E(%,1,12) S RUNDATE=$$FMTE^XLFDT(Y)
I '$G(ECXPORT) D HEADER I STOP D EXIT Q
D GETDATA I $G(ECXPORT) Q ;Have data, no need to print.
I '$D(^TMP("ECXDRG",$J)) D Q
.W !
. W !,"+=========================+"
. W !,"| No DRG data available |"
. W !,"+=========================+"
. D WAIT
D DETAIL I STOP D EXIT Q
K ^TMP("ECXDRG",$J)
Q
;
GETDATA ;
S DA=0 F S DA=$O(^ICD(DA)) Q:(+DA=0) D
. S CNT=CNT+1
. S NAME=$P(^ICD(DA,0),U,1)
. S EFFDA=$O(^ICD(DA,66,9999999),-1)
. S NODE0=$G(^ICD(DA,66,EFFDA,0))
. S EFFDT=$$FMTE^XLFDT($P(NODE0,U,1))
. S STAT=$P(NODE0,U,3)
. S INACT=$S(STAT=0:EFFDT,1:"")
. S STAT=$S(STAT=0:"Inactive",1:"Active")
. S NESI=NAME_U_EFFDT_U_STAT_U_INACT
. S ^TMP("ECXDRG",$J,CNT)=NESI
. ; Get description (which may be multiple lines)
. S DESCDA=$O(^ICD(DA,68,999999),-1)
. S NODE0=$G(^ICD(DA,68,DESCDA,0))
. S (LINECT,LINEDA)=0 F S LINEDA=$O(^ICD(DA,68,DESCDA,1,LINEDA)) Q:'LINEDA D
. . I $G(ECXPORT) S:LINEDA>1 CNT=CNT+1 S ^TMP("ECXDRG",$J,CNT)=NESI_U_^ICD(DA,68,DESCDA,1,LINEDA,0) Q
. . S LINECT=LINECT+1
. . S ^TMP("ECXDRG",$J,CNT,LINECT)=^ICD(DA,68,DESCDA,1,LINEDA,0)
. Q
Q
S PAGENUM=PAGENUM+1
W @IOF
W !,?45,"Diagnosis Related Group (DRG) Report",?120,"Page: ",PAGENUM
W !,?43,"Report Run Date/Time: "_RUNDATE
W !!!,"DRG NAME",?35,"EFFECTIVE DATE",?56,"STATUS",?68,"INACTIVATION DATE",!,LN,!
Q
;
DETAIL ;Print detailed line
; Input : ^TMP("ECXDRG",$J) full global reference
; Output : None
N RECORD,NODE,DLINE,BLANK
S RECORD=0 F S RECORD=$O(^TMP("ECXDRG",$J,RECORD)) Q:'RECORD!(STOP) D
. S BLANK=1 S NODE=^TMP("ECXDRG",$J,RECORD)
. W !,$P(NODE,U,1),?36,$P(NODE,U,2),?56,$P(NODE,U,3),?70,$P(NODE,U,4)
. W !,"DESCRIPTION:"
. S DLINE=0 F S DLINE=$O(^TMP("ECXDRG",$J,RECORD,DLINE)) Q:'DLINE S BLANK=0 W ?14,^TMP("ECXDRG",$J,RECORD,DLINE),!
. W:BLANK !
. I $Y>(IOSL-5) D WAIT Q:STOP D HEADER
Q
;
WAIT ;End of page logic
;Input ; None
;Output ; STOP - Flag inidcating if printing should continue
; 1 = Stop 0 = Continue
S STOP=0
I $E(IOST,1,2)="C-" D Q ; CRT - Prompt for continue
. F Q:$Y>(IOSL-3) W !
. N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
. S DIR(0)="E"
. D ^DIR
. S STOP=$S(Y'=1:1,1:0)
S STOP=$$S^%ZTLOAD() ; Background task - check TaskMan
I STOP D
. W !,"**************************************************"
. W !,"* Printing of DRG report stopped, as requested *"
. W !,"**************************************************"
Q
EXIT ;Kill temp global
K ^TMP("ECXDRG",$J)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXDRG 3650 printed Sep 23, 2025@19:28:29 Page 2
ECXDRG ;ALB/TJL - DRG Report ;4/2/24 15:12
+1 ;;3.0;DSS EXTRACTS;**190**;Dec 22, 1997;Build 36
+2 ;
EN ; Entry point from menu option
+1 NEW I,X,Y,DIR,ECXPORT
+2 ;S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ; The output can only be exported,
+3 ; but code to send output to the screen is retained - tjl FY25 - 190
SET ECXPORT=1
Begin DoDot:1
+4 KILL ^TMP($JOB,"ECXPORT")
+5 SET ^TMP($JOB,"ECXPORT",0)="DRG^EFFECTIVE DATE^STATUS^INACTIVE DATE^DRG DESCRIPTION"
+6 DO EN1
+7 MERGE ^TMP($JOB,"ECXPORT")=^TMP("ECXDRG",$JOB)
+8 DO EXPDISP^ECXUTL1
End DoDot:1
QUIT
+9 ;
+10 ; Queue Report
+11 WRITE !!,"** Report requires 132 columns to print correctly **",!!
+12 NEW ZTDESC,ZTIO,ZTSAVE
+13 SET ZTIO=""
+14 SET ZTDESC="Diagnosis Related Group"
+15 FOR I="NAME","EFF DATE","STATUS","INACT DATE"
Begin DoDot:1
+16 SET ZTSAVE(I)=""
End DoDot:1
+17 DO EN^XUTMDEVQ("EN1^ECXDRG",ZTDESC,.ZTSAVE)
+18 QUIT
EN1 ; Tasked entry point
+1 ; Declare variables
+2 NEW U,DA,LN,DESC,NAME,STAT,INACT,LINEDA,LINECT,NODE0,PAGENUM,NESI
+3 NEW DIC,DR,DIQ,CNT,STOP,QFLG,RUNDATE
+4 KILL ^TMP("ECXDRG",$JOB)
+5 SET U="^"
SET $PIECE(LN,"-",132)=""
+6 SET (CNT,QFLG,PAGENUM,STOP)=0
+7 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
SET RUNDATE=$$FMTE^XLFDT(Y)
+8 IF '$GET(ECXPORT)
DO HEADER
IF STOP
DO EXIT
QUIT
+9 ;Have data, no need to print.
DO GETDATA
IF $GET(ECXPORT)
QUIT
+10 IF '$DATA(^TMP("ECXDRG",$JOB))
Begin DoDot:1
+11 WRITE !
+12 WRITE !,"+=========================+"
+13 WRITE !,"| No DRG data available |"
+14 WRITE !,"+=========================+"
+15 DO WAIT
End DoDot:1
QUIT
+16 DO DETAIL
IF STOP
DO EXIT
QUIT
+17 KILL ^TMP("ECXDRG",$JOB)
+18 QUIT
+19 ;
GETDATA ;
+1 SET DA=0
FOR
SET DA=$ORDER(^ICD(DA))
if (+DA=0)
QUIT
Begin DoDot:1
+2 SET CNT=CNT+1
+3 SET NAME=$PIECE(^ICD(DA,0),U,1)
+4 SET EFFDA=$ORDER(^ICD(DA,66,9999999),-1)
+5 SET NODE0=$GET(^ICD(DA,66,EFFDA,0))
+6 SET EFFDT=$$FMTE^XLFDT($PIECE(NODE0,U,1))
+7 SET STAT=$PIECE(NODE0,U,3)
+8 SET INACT=$SELECT(STAT=0:EFFDT,1:"")
+9 SET STAT=$SELECT(STAT=0:"Inactive",1:"Active")
+10 SET NESI=NAME_U_EFFDT_U_STAT_U_INACT
+11 SET ^TMP("ECXDRG",$JOB,CNT)=NESI
+12 ; Get description (which may be multiple lines)
+13 SET DESCDA=$ORDER(^ICD(DA,68,999999),-1)
+14 SET NODE0=$GET(^ICD(DA,68,DESCDA,0))
+15 SET (LINECT,LINEDA)=0
FOR
SET LINEDA=$ORDER(^ICD(DA,68,DESCDA,1,LINEDA))
if 'LINEDA
QUIT
Begin DoDot:2
+16 IF $GET(ECXPORT)
if LINEDA>1
SET CNT=CNT+1
SET ^TMP("ECXDRG",$JOB,CNT)=NESI_U_^ICD(DA,68,DESCDA,1,LINEDA,0)
QUIT
+17 SET LINECT=LINECT+1
+18 SET ^TMP("ECXDRG",$JOB,CNT,LINECT)=^ICD(DA,68,DESCDA,1,LINEDA,0)
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+1 SET PAGENUM=PAGENUM+1
+2 WRITE @IOF
+3 WRITE !,?45,"Diagnosis Related Group (DRG) Report",?120,"Page: ",PAGENUM
+4 WRITE !,?43,"Report Run Date/Time: "_RUNDATE
+5 WRITE !!!,"DRG NAME",?35,"EFFECTIVE DATE",?56,"STATUS",?68,"INACTIVATION DATE",!,LN,!
+6 QUIT
+7 ;
DETAIL ;Print detailed line
+1 ; Input : ^TMP("ECXDRG",$J) full global reference
+2 ; Output : None
+3 NEW RECORD,NODE,DLINE,BLANK
+4 SET RECORD=0
FOR
SET RECORD=$ORDER(^TMP("ECXDRG",$JOB,RECORD))
if 'RECORD!(STOP)
QUIT
Begin DoDot:1
+5 SET BLANK=1
SET NODE=^TMP("ECXDRG",$JOB,RECORD)
+6 WRITE !,$PIECE(NODE,U,1),?36,$PIECE(NODE,U,2),?56,$PIECE(NODE,U,3),?70,$PIECE(NODE,U,4)
+7 WRITE !,"DESCRIPTION:"
+8 SET DLINE=0
FOR
SET DLINE=$ORDER(^TMP("ECXDRG",$JOB,RECORD,DLINE))
if 'DLINE
QUIT
SET BLANK=0
WRITE ?14,^TMP("ECXDRG",$JOB,RECORD,DLINE),!
+9 if BLANK
WRITE !
+10 IF $Y>(IOSL-5)
DO WAIT
if STOP
QUIT
DO HEADER
End DoDot:1
+11 QUIT
+12 ;
WAIT ;End of page logic
+1 ;Input ; None
+2 ;Output ; STOP - Flag inidcating if printing should continue
+3 ; 1 = Stop 0 = Continue
+4 SET STOP=0
+5 ; CRT - Prompt for continue
IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+6 FOR
if $Y>(IOSL-3)
QUIT
WRITE !
+7 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+8 SET DIR(0)="E"
+9 DO ^DIR
+10 SET STOP=$SELECT(Y'=1:1,1:0)
End DoDot:1
QUIT
+11 ; Background task - check TaskMan
SET STOP=$$S^%ZTLOAD()
+12 IF STOP
Begin DoDot:1
+13 WRITE !,"**************************************************"
+14 WRITE !,"* Printing of DRG report stopped, as requested *"
+15 WRITE !,"**************************************************"
End DoDot:1
+16 QUIT
EXIT ;Kill temp global
+1 KILL ^TMP("ECXDRG",$JOB)
+2 QUIT
+3 ;
