ECXAMTL ;ALB/JAM - MTL Extract Audit Report; May 24, 1999 ;10/22/13 17:31
;;3.0;DSS EXTRACTS;**24,44,148**;Dec 22, 1997;Build 3
EN ;entry point for MTL extract audit report
N %X,%Y
;ecxaud=0 for 'extract' audit
S ECXERR=0
S ECXHEAD="MTL",ECXAUD=0
W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
;select extract
D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) I ECXERR D Q
. K ECXHEAD,ECXAUD,ECXERR
;get facility/division
S ECXALL=1
D MTL^ECXDVSN2(.ECXDIV,ECXALL,.ECXERR) I ECXERR D AUDIT^ECXKILL Q
;select output device and queue report if requested
S ECXPGM="PROCESS^ECXAMTL",ECXDESC="MTL Extract Audit Report"
S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")=""
S ECXSAVE("ECXARRAY(")="" W !
D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
I ECXSAVE("POP")=1 D Q
. W !!,?5,"Try again later... exiting.",!
. D AUDIT^ECXKILL
I ECXSAVE("ZTSK")=0 D
. K ECXSAVE,ECXPGM,ECXDESC
. D PROCESS^ECXAMTL
I IO'=IO(0) D ^%ZISC
D HOME^%ZIS
D AUDIT^ECXKILL
Q
PROCESS ;process data in file #727.812
N DAY,MTLDAT,MTLDAT1,SSN,NAME,EXN,IEN,ASI,SPC,TSTNAM,PROV,DATND,TSTSC
N NODE
K ^TMP($J,"ECXMTL") S EXN=ECXARRAY("EXTRACT")
;set start and end date in interal format
S X=ECXARRAY("START") S %DT="" D ^%DT S ECXSTART=Y
S X=ECXARRAY("END") D ^%DT S ECXEND=Y
;get run date in external format
D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
;get records for specified date range within extract
S IEN=0 F S IEN=$O(^ECX(727.812,"AC",EXN,IEN)) Q:'IEN D
. S MTLDAT=^ECX(727.812,IEN,0),MTLDAT1=$G(^ECX(727.812,IEN,1))
. ;convert date to fileman internal format
. S DAY=$P(MTLDAT,U,9),$E(DAY,1,2)=$E(DAY,1,2)-17 Q:$L(DAY)<7
. I DAY<ECXSTART!(DAY>ECXEND) Q
. S SSN=$P(MTLDAT,U,6),NAME=$P(MTLDAT,U,7),TSTNAM=$P(MTLDAT,U,21)
. S PROV=$P(MTLDAT,U,18)
. S:PROV'="" PROV=$$GET1^DIQ(200,$E(PROV,2,999),.01,"I")
. S TSTSC=$P(MTLDAT,U,25),ASI=$P(MTLDAT1,U,5),SPC=$P(MTLDAT1,U,6)
. ;determine next level for ^TMP($J,"ECXMTL",
. Q:TSTNAM="" S NODE=TSTNAM I TSTNAM'="ASI",TSTNAM'="GAF" S NODE="PI"
. ;data to be stored at node in ^TMP($J,"ECXMTL,NODE
. S DATND=$S(NODE="ASI":ASI_U_SPC,NODE="GAF":TSTSC_U_PROV,1:"")
. ;store data in ^TMP($J,"ECXMTL",NODE
. I NODE="PI" D Q
. . I '$D(^TMP($J,"ECXMTL",NODE,TSTNAM,NAME,SSN,DAY)) D
. . . S ^TMP($J,"ECXMTL",NODE,TSTNAM,NAME,SSN,DAY)=DATND
. . . S ^TMP($J,"ECXMTL",NODE,TSTNAM)=$G(^TMP($J,"ECXMTL",NODE,TSTNAM))+1
. I '$D(^TMP($J,"ECXMTL",NODE,NAME,SSN,DAY)) D
. . S ^TMP($J,"ECXMTL",NODE,NAME,SSN,DAY)=DATND
D PRINT,AUDIT^ECXKILL
Q
PRINT ;print the MTL audit report
N ND,NAM,SSN,DAY,PITOT,GAFTOT,ASI,INSTOT,CNT,DIV,QFL,LN,I,CLS,SPC,ASISP
N PG,ASITOT,ASISPTOT
U IO
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
S (ASITOT,ASISPTOT,QFL,PG,CNT)=0,$P(LN,"-",74)="",DIV=$O(ECXDIV(""))
;
;- Added new class, ASI-MV, per MH patch YS*5.01*67
F I=1:1:4,999 S (ASI(I),ASISP(I))=0 D
. S ASI(I,0)=$S(I=1:"Full",I=2:"Lite",I=3:"Follow-up",I=4:"For ASI-MV",1:"Unspecified")
. S ASISP(I,0)=$S(I=1:"Terminated",I=2:"Refused",I=3:"Unable",1:"Unspecified")
S ASISP(0)=0,ASISP(0,0)="Completed" D HEADER
S ND="" F S ND=$O(^TMP($J,"ECXMTL",ND)) Q:ND="" D I QFL Q
. S CNT=CNT+1 D H1 S NAM="" I ($Y+3)>IOSL D HEADER I QFL Q
. I ND="PI" D Q
. . F S NAM=$O(^TMP($J,"ECXMTL",ND,NAM)) Q:NAM="" D I QFL Q
. . . S INSTOT=^TMP($J,"ECXMTL",ND,NAM)
. . . D:($Y+3)>IOSL HEADER Q:QFL W ?5,NAM,?32,$J(INSTOT,8),!
. . . S PITOT=$G(PITOT)+INSTOT
. . I ($Y+3)>IOSL D HEADER I QFL Q
. . W ?5,LN,!,?5,"Total",?30,$J(PITOT,10),!
. F S NAM=$O(^TMP($J,"ECXMTL",ND,NAM)) Q:NAM="" S SSN="" D I QFL Q
. .F S SSN=$O(^TMP($J,"ECXMTL",ND,NAM,SSN)) Q:SSN="" S DAY="" D Q:QFL
. . . F S DAY=$O(^TMP($J,"ECXMTL",ND,NAM,SSN,DAY)) Q:DAY="" D P1 Q:QFL
. I QFL Q
. ;print GAF total
. I ND="GAF" D Q
. . D:($Y+3)>IOSL HEADER Q:QFL W ?5,LN,!,?5,"Total: ",GAFTOT,!
. ;print ASI totals
. I ND="ASI" D Q
. . D:($Y+3)>IOSL HEADER Q:QFL W ?5,LN,! S (CLS,SPC)=-1
. . F I=1:1:5 D Q:(CLS="")&(SPC="") I QFL Q
. . . I ($Y+3)>IOSL D HEADER I QFL Q
. . . I CLS'="" S CLS=$O(ASI(CLS)) D:CLS'=""
. . . . W ?29,$J(ASI(CLS),8)," ",ASI(CLS,0)
. . . . S ASITOT=ASITOT+ASI(CLS)
. . . I SPC'="" S SPC=$O(ASISP(SPC)) D:SPC'=""
. . . . W ?50,$J(ASISP(SPC),8)," ",ASISP(SPC,0) D
. . . . S ASISPTOT=ASISPTOT+ASISP(SPC)
. . . W !
. . Q:QFL W ?5,LN,!,?27,$J(ASITOT,10),?48,$J(ASISPTOT,10)," ","Total"
Q
P1 ;print ASI and GAF records
N DATND,DATE
S DATND=^TMP($J,"ECXMTL",ND,NAM,SSN,DAY)
S DATE=$E(DAY,4,5)_"/"_$E(DAY,6,7)_"/"_($E(DAY)+17)_$E(DAY,2,3)
D:($Y+3)>IOSL HEADER Q:QFL W ?5,NAM,?14,$E(SSN,$L(SSN)-3,$L(SSN))
I ND="ASI" D Q
. S CLS=$P(DATND,U),SPC=$P(DATND,U,2)
. W ?21,DATE,?36,$S(CLS=1:"Full",CLS=2:"Lite",CLS=3:"F-up",CLS=4:"ASI-MV",1:""),?57,SPC,!
. S:CLS="" CLS=999 S:SPC="" SPC=999 S:SPC="N" SPC=0
. S ASI(CLS)=$G(ASI(CLS))+1,ASISP(SPC)=$G(ASISP(SPC))+1
I ND="GAF" D Q
. W ?21,DATE,?36,$P(DATND,U,2),!
. S GAFTOT=$G(GAFTOT)+1
Q
N JJ,SS
I $E(IOST)="C" D I QFL Q
. S SS=22-$Y F JJ=1:1:SS W !
. I PG S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFL=1
W:PG!($E(IOST)="C") @IOF S PG=PG+1
W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
W !,"Report Run Date/Time: "_ECXRUN
I $P(ECXDIV(DIV),U)="" D
. S $P(ECXDIV(DIV),U)=$P(ECXDIV(DIV),U,3)
. I $P(ECXDIV(DIV),U)="" S $P(ECXDIV(DIV),U)="Unknown"
W !,"Facility: "_$P(ECXDIV(DIV),U)
W " ("_$P(ECXDIV(DIV),U,4)_")",?68,"Page: "_PG
H1 I $G(ND)'="" D
. W !!,CNT,".",?5
. I ND="PI" W "Psych Instruments segment",!! Q
. W ND," segment",!!
. W ?5,"Name",?14,"SSN",?21
. I ND="ASI" W "Interview",?36,"Class",?54,"Special"
. I ND="GAF" W "Date",?36,"Clinician"
. W !,?5,LN,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXAMTL 5937 printed Apr 09, 2024@20:57:05 Page 2
ECXAMTL ;ALB/JAM - MTL Extract Audit Report; May 24, 1999 ;10/22/13 17:31
+1 ;;3.0;DSS EXTRACTS;**24,44,148**;Dec 22, 1997;Build 3
EN ;entry point for MTL extract audit report
+1 NEW %X,%Y
+2 ;ecxaud=0 for 'extract' audit
+3 SET ECXERR=0
+4 SET ECXHEAD="MTL"
SET ECXAUD=0
+5 WRITE !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
+6 ;select extract
+7 DO AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
IF ECXERR
Begin DoDot:1
+8 KILL ECXHEAD,ECXAUD,ECXERR
End DoDot:1
QUIT
+9 ;get facility/division
+10 SET ECXALL=1
+11 DO MTL^ECXDVSN2(.ECXDIV,ECXALL,.ECXERR)
IF ECXERR
DO AUDIT^ECXKILL
QUIT
+12 ;select output device and queue report if requested
+13 SET ECXPGM="PROCESS^ECXAMTL"
SET ECXDESC="MTL Extract Audit Report"
+14 SET ECXSAVE("ECXHEAD")=""
SET ECXSAVE("ECXALL")=""
SET ECXSAVE("ECXDIV(")=""
+15 SET ECXSAVE("ECXARRAY(")=""
WRITE !
+16 DO DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
+17 IF ECXSAVE("POP")=1
Begin DoDot:1
+18 WRITE !!,?5,"Try again later... exiting.",!
+19 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+20 IF ECXSAVE("ZTSK")=0
Begin DoDot:1
+21 KILL ECXSAVE,ECXPGM,ECXDESC
+22 DO PROCESS^ECXAMTL
End DoDot:1
+23 IF IO'=IO(0)
DO ^%ZISC
+24 DO HOME^%ZIS
+25 DO AUDIT^ECXKILL
+26 QUIT
PROCESS ;process data in file #727.812
+1 NEW DAY,MTLDAT,MTLDAT1,SSN,NAME,EXN,IEN,ASI,SPC,TSTNAM,PROV,DATND,TSTSC
+2 NEW NODE
+3 KILL ^TMP($JOB,"ECXMTL")
SET EXN=ECXARRAY("EXTRACT")
+4 ;set start and end date in interal format
+5 SET X=ECXARRAY("START")
SET %DT=""
DO ^%DT
SET ECXSTART=Y
+6 SET X=ECXARRAY("END")
DO ^%DT
SET ECXEND=Y
+7 ;get run date in external format
+8 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET ECXRUN=Y
+9 ;get records for specified date range within extract
+10 SET IEN=0
FOR
SET IEN=$ORDER(^ECX(727.812,"AC",EXN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+11 SET MTLDAT=^ECX(727.812,IEN,0)
SET MTLDAT1=$GET(^ECX(727.812,IEN,1))
+12 ;convert date to fileman internal format
+13 SET DAY=$PIECE(MTLDAT,U,9)
SET $EXTRACT(DAY,1,2)=$EXTRACT(DAY,1,2)-17
if $LENGTH(DAY)<7
QUIT
+14 IF DAY<ECXSTART!(DAY>ECXEND)
QUIT
+15 SET SSN=$PIECE(MTLDAT,U,6)
SET NAME=$PIECE(MTLDAT,U,7)
SET TSTNAM=$PIECE(MTLDAT,U,21)
+16 SET PROV=$PIECE(MTLDAT,U,18)
+17 if PROV'=""
SET PROV=$$GET1^DIQ(200,$EXTRACT(PROV,2,999),.01,"I")
+18 SET TSTSC=$PIECE(MTLDAT,U,25)
SET ASI=$PIECE(MTLDAT1,U,5)
SET SPC=$PIECE(MTLDAT1,U,6)
+19 ;determine next level for ^TMP($J,"ECXMTL",
+20 if TSTNAM=""
QUIT
SET NODE=TSTNAM
IF TSTNAM'="ASI"
IF TSTNAM'="GAF"
SET NODE="PI"
+21 ;data to be stored at node in ^TMP($J,"ECXMTL,NODE
+22 SET DATND=$SELECT(NODE="ASI":ASI_U_SPC,NODE="GAF":TSTSC_U_PROV,1:"")
+23 ;store data in ^TMP($J,"ECXMTL",NODE
+24 IF NODE="PI"
Begin DoDot:2
+25 IF '$DATA(^TMP($JOB,"ECXMTL",NODE,TSTNAM,NAME,SSN,DAY))
Begin DoDot:3
+26 SET ^TMP($JOB,"ECXMTL",NODE,TSTNAM,NAME,SSN,DAY)=DATND
+27 SET ^TMP($JOB,"ECXMTL",NODE,TSTNAM)=$GET(^TMP($JOB,"ECXMTL",NODE,TSTNAM))+1
End DoDot:3
End DoDot:2
QUIT
+28 IF '$DATA(^TMP($JOB,"ECXMTL",NODE,NAME,SSN,DAY))
Begin DoDot:2
+29 SET ^TMP($JOB,"ECXMTL",NODE,NAME,SSN,DAY)=DATND
End DoDot:2
End DoDot:1
+30 DO PRINT
DO AUDIT^ECXKILL
+31 QUIT
PRINT ;print the MTL audit report
+1 NEW ND,NAM,SSN,DAY,PITOT,GAFTOT,ASI,INSTOT,CNT,DIV,QFL,LN,I,CLS,SPC,ASISP
+2 NEW PG,ASITOT,ASISPTOT
+3 USE IO
+4 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
QUIT
+5 SET (ASITOT,ASISPTOT,QFL,PG,CNT)=0
SET $PIECE(LN,"-",74)=""
SET DIV=$ORDER(ECXDIV(""))
+6 ;
+7 ;- Added new class, ASI-MV, per MH patch YS*5.01*67
+8 FOR I=1:1:4,999
SET (ASI(I),ASISP(I))=0
Begin DoDot:1
+9 SET ASI(I,0)=$SELECT(I=1:"Full",I=2:"Lite",I=3:"Follow-up",I=4:"For ASI-MV",1:"Unspecified")
+10 SET ASISP(I,0)=$SELECT(I=1:"Terminated",I=2:"Refused",I=3:"Unable",1:"Unspecified")
End DoDot:1
+11 SET ASISP(0)=0
SET ASISP(0,0)="Completed"
DO HEADER
+12 SET ND=""
FOR
SET ND=$ORDER(^TMP($JOB,"ECXMTL",ND))
if ND=""
QUIT
Begin DoDot:1
+13 SET CNT=CNT+1
DO H1
SET NAM=""
IF ($Y+3)>IOSL
DO HEADER
IF QFL
QUIT
+14 IF ND="PI"
Begin DoDot:2
+15 FOR
SET NAM=$ORDER(^TMP($JOB,"ECXMTL",ND,NAM))
if NAM=""
QUIT
Begin DoDot:3
+16 SET INSTOT=^TMP($JOB,"ECXMTL",ND,NAM)
+17 if ($Y+3)>IOSL
DO HEADER
if QFL
QUIT
WRITE ?5,NAM,?32,$JUSTIFY(INSTOT,8),!
+18 SET PITOT=$GET(PITOT)+INSTOT
End DoDot:3
IF QFL
QUIT
+19 IF ($Y+3)>IOSL
DO HEADER
IF QFL
QUIT
+20 WRITE ?5,LN,!,?5,"Total",?30,$JUSTIFY(PITOT,10),!
End DoDot:2
QUIT
+21 FOR
SET NAM=$ORDER(^TMP($JOB,"ECXMTL",ND,NAM))
if NAM=""
QUIT
SET SSN=""
Begin DoDot:2
+22 FOR
SET SSN=$ORDER(^TMP($JOB,"ECXMTL",ND,NAM,SSN))
if SSN=""
QUIT
SET DAY=""
Begin DoDot:3
+23 FOR
SET DAY=$ORDER(^TMP($JOB,"ECXMTL",ND,NAM,SSN,DAY))
if DAY=""
QUIT
DO P1
if QFL
QUIT
End DoDot:3
if QFL
QUIT
End DoDot:2
IF QFL
QUIT
+24 IF QFL
QUIT
+25 ;print GAF total
+26 IF ND="GAF"
Begin DoDot:2
+27 if ($Y+3)>IOSL
DO HEADER
if QFL
QUIT
WRITE ?5,LN,!,?5,"Total: ",GAFTOT,!
End DoDot:2
QUIT
+28 ;print ASI totals
+29 IF ND="ASI"
Begin DoDot:2
+30 if ($Y+3)>IOSL
DO HEADER
if QFL
QUIT
WRITE ?5,LN,!
SET (CLS,SPC)=-1
+31 FOR I=1:1:5
Begin DoDot:3
+32 IF ($Y+3)>IOSL
DO HEADER
IF QFL
QUIT
+33 IF CLS'=""
SET CLS=$ORDER(ASI(CLS))
if CLS'=""
Begin DoDot:4
+34 WRITE ?29,$JUSTIFY(ASI(CLS),8)," ",ASI(CLS,0)
+35 SET ASITOT=ASITOT+ASI(CLS)
End DoDot:4
+36 IF SPC'=""
SET SPC=$ORDER(ASISP(SPC))
if SPC'=""
Begin DoDot:4
+37 WRITE ?50,$JUSTIFY(ASISP(SPC),8)," ",ASISP(SPC,0)
Begin DoDot:5
End DoDot:5
+38 SET ASISPTOT=ASISPTOT+ASISP(SPC)
End DoDot:4
+39 WRITE !
End DoDot:3
if (CLS="")&(SPC="")
QUIT
IF QFL
QUIT
+40 if QFL
QUIT
WRITE ?5,LN,!,?27,$JUSTIFY(ASITOT,10),?48,$JUSTIFY(ASISPTOT,10)," ","Total"
End DoDot:2
QUIT
End DoDot:1
IF QFL
QUIT
+41 QUIT
P1 ;print ASI and GAF records
+1 NEW DATND,DATE
+2 SET DATND=^TMP($JOB,"ECXMTL",ND,NAM,SSN,DAY)
+3 SET DATE=$EXTRACT(DAY,4,5)_"/"_$EXTRACT(DAY,6,7)_"/"_($EXTRACT(DAY)+17)_$EXTRACT(DAY,2,3)
+4 if ($Y+3)>IOSL
DO HEADER
if QFL
QUIT
WRITE ?5,NAM,?14,$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))
+5 IF ND="ASI"
Begin DoDot:1
+6 SET CLS=$PIECE(DATND,U)
SET SPC=$PIECE(DATND,U,2)
+7 WRITE ?21,DATE,?36,$SELECT(CLS=1:"Full",CLS=2:"Lite",CLS=3:"F-up",CLS=4:"ASI-MV",1:""),?57,SPC,!
+8 if CLS=""
SET CLS=999
if SPC=""
SET SPC=999
if SPC="N"
SET SPC=0
+9 SET ASI(CLS)=$GET(ASI(CLS))+1
SET ASISP(SPC)=$GET(ASISP(SPC))+1
End DoDot:1
QUIT
+10 IF ND="GAF"
Begin DoDot:1
+11 WRITE ?21,DATE,?36,$PIECE(DATND,U,2),!
+12 SET GAFTOT=$GET(GAFTOT)+1
End DoDot:1
QUIT
+13 QUIT
+1 NEW JJ,SS
+2 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+4 IF PG
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if 'Y
SET QFL=1
End DoDot:1
IF QFL
QUIT
+5 if PG!($EXTRACT(IOST)="C")
WRITE @IOF
SET PG=PG+1
+6 WRITE !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
+7 WRITE !,"DSS Extract Log #: "_ECXARRAY("EXTRACT")
+8 WRITE !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END")
+9 WRITE !,"Report Run Date/Time: "_ECXRUN
+10 IF $PIECE(ECXDIV(DIV),U)=""
Begin DoDot:1
+11 SET $PIECE(ECXDIV(DIV),U)=$PIECE(ECXDIV(DIV),U,3)
+12 IF $PIECE(ECXDIV(DIV),U)=""
SET $PIECE(ECXDIV(DIV),U)="Unknown"
End DoDot:1
+13 WRITE !,"Facility: "_$PIECE(ECXDIV(DIV),U)
+14 WRITE " ("_$PIECE(ECXDIV(DIV),U,4)_")",?68,"Page: "_PG
H1 IF $GET(ND)'=""
Begin DoDot:1
+1 WRITE !!,CNT,".",?5
+2 IF ND="PI"
WRITE "Psych Instruments segment",!!
QUIT
+3 WRITE ND," segment",!!
+4 WRITE ?5,"Name",?14,"SSN",?21
+5 IF ND="ASI"
WRITE "Interview",?36,"Class",?54,"Special"
+6 IF ND="GAF"
WRITE "Date",?36,"Clinician"
+7 WRITE !,?5,LN,!
End DoDot:1
+8 QUIT
