ACHSTX7X ; IHS/ITSC/TPF/PMF - CHS TRIBAL STATISTICAL EXPORT ERROR REPORT ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22,23**;JUN 11, 2001;Build 43
;
; Produces report for incomplete data items for Statisitcal (638)
; records to be sent to DDPS.
;
; Sites can use the "Enter/Edit Medical Data" to fill in any
; missing ICD9 or APC codes, and the Vendor edit option to
; fill in an EIN or Vendor Type. Bad Admit/Discharge dates are
; rare and will have to be fixed w/FM.
;
; THANKS TO FONDA JACKSON OF PORTLAND FOR THE ORIGINAL ROUTINE.
;
I $$PARM^ACHS(0,8)'="Y" W !,"Your site is not a 638 facility." D RTRN^ACHS Q
;
DEV ;
S %ZIS="MQP"
D ^%ZIS
G:POP CLOSE
G:'$D(IO("Q")) START
S ZTRTN="START^ACHSTX7X",ZTDESC=$$DESC
D ^%ZTLOAD,HOME^%ZIS
G CLOSE
;
START ;EP - From TaskMan.
K ^TMP("ACHSTX7X",$J)
N ACHSBDTS,ACHSEIN,ACHSFC,ACHSFYDT
D SETUP
D CALC
D PRINT
D CLOSE
Q
;
SETUP ; ----- Set vars. --------------------------------------------------
D FY^ACHSUF,FC^ACHSUF
S (ACHSDCR,ACHSBDT)=0,ACHSEDT=DT
S X=$O(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",0))
I X?7N D
. S ACHSDCR=$O(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",X,ACHSDCR))
. S ACHSEDT=$P(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSDCR,0),U,2)
. S ACHSBDT=$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSDCR-1,0)),U,2)
. I ACHSBDT'?7N S ACHSBDT=ACHSFYDT-10000
.Q
I ACHSDCR=0 S ACHSBDT=ACHSFYDT-10000
S ACHSBDTS=ACHSBDT
Q
;
CALC ; ----- Check for documents with incomplete data items. ------------
F S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT)) Q:(ACHSBDT>ACHSEDT)!(ACHSBDT'?7N) D
. Q:'$D(^ACHSF(DUZ(2),"TB",ACHSBDT,"P"))
. S ACHSDIEN=0
. F S ACHSDIEN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,"P",ACHSDIEN)) Q:ACHSDIEN'?1N.N D
.. Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)
.. S ACHSTIEN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,"P",ACHSDIEN,0))
.. S ACHSDOCR=^ACHSF(DUZ(2),"D",ACHSDIEN,0),ACHSTOS=$P(ACHSDOCR,U,4)
.. D CHK
..Q
.Q
Q
;
CHK ; --- Text at CHK_ labels are used in report.
F %=1:1:4 S ACHSERR(%)=0
S ACHSTST=0
CHK1 ;ERROR IN ICD-9 CODE; Error 1.
G:($$PARM^ACHS(0,18)-1)<$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,10) CHK2 ;ACHS*3.1*23 ONLY TST ICD9 TYPE
D DXPX^ACHSTX7A
;I ACHSTOS=1,+ACHSDX(1)<1 S ACHSERR(1)=1,ACHSTST=1 G CHK2
I ACHSTOS=1,'(+ACHSDX(1)>0),"EV"'[$E(ACHSDX(1)) S ACHSERR(1)=1,ACHSTST=1 G CHK2
I ACHSTOS=2 G CHK2
I ACHSTOS=3,+ACHSAPC(1)<1 S ACHSERR(1)=1,ACHSTST=1
CHK2 ;INVALID EIN; Error 2.
I '$P(ACHSDOCR,U,8) S ACHSERR(2)=1,ACHSTST=1,ACHSEIN="" G CHK4
S (ACHSEIN,X)=$P($G(^AUTTVNDR($P(ACHSDOCR,U,8),11)),U)
X $P(^DD(9999999.11,1101,0),U,5,99)
I '$D(X) S ACHSERR(2)=1,ACHSTST=1 G CHK3
I "12"'[$E(X) S ACHSERR(2)=1,ACHSTST=1
CHK3 ;INVALID PROVIDER TYPE; Error 3.
S X=$P($G(^AUTTVNDR($P(ACHSDOCR,U,8),11)),U,3)
I X<1 S ACHSERR(3)=1,ACHSTST=1
I X,'$D(^AUTTVTYP(X,0)) S ACHSERR(3)=1,ACHSTST=1
CHK4 ;INVALID ADMISSION/DISCHARGE DATE; Error 4.
I ACHSTOS=1 D
. S X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,2)
. S Y=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,3)
. ;ACHS*3.1*22 IHS.OIT.FCJ MODIFIED TO TEST ADM DT > DISCHARGE DT
. ;S:(Y>ACHSBDT)!(Y>ACHSEDT)!(X>ACHSEDT)!(X'?7N)!(Y'?7N) ACHSERR(4)=1,ACHSTST=1
.S:(Y<X)!(X'?7N)!(Y'?7N)!($P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U)>Y)!(X<$P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U)) ACHSERR(4)=1,ACHSTST=1
.Q
CHKEND ; ----- Set TMP Global with document Errors.
Q:ACHSTST=0
S ^TMP("ACHSTX7X",$J,ACHSTOS,ACHSDIEN)=$P(ACHSDOCR,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOCR,U)
F %=1:1:4 S $P(^TMP("ACHSTX7X",$J,ACHSTOS,ACHSDIEN),U,%+1)=ACHSERR(%)
S $P(^TMP("ACHSTX7X",$J,ACHSTOS,ACHSDIEN),U,6)=ACHSEIN
Q
;
CLOSE ; ----- Close device, kill vars, quit. -----------------------------
D ^%ZISC
K ACHSTOS,ACHSDX,ACHSAPC,ACHSERR,ACHSTST,ACHSDOCR,ACHSDIEN,ACHSTIEN,ACHSPX,ACHSCFY,ACHSX,ACHSY,ACHSPG,R,ACHSBDT,ACHSDCR,ACHS,ACHSEDT,^TMP("ACHSTX7X",$J)
Q
;
PRINT ; ----- Print Errors. ----------------------------------------------
U IO
S ACHSPG=0
D PHDR
S (ACHSTOS(1),ACHSTOS(2),ACHSTOS(3))=0
I $D(^TMP("ACHSTX7X",$J)) D
. F ACHSTOS=1,2,3 S ACHSDIEN=0 F S ACHSDIEN=$O(^TMP("ACHSTX7X",$J,ACHSTOS,ACHSDIEN)) Q:ACHSDIEN'?1N.N D Q:$D(DUOUT)
.. S ACHSTOS(ACHSTOS)=ACHSTOS(ACHSTOS)+1
.. I $Y>(IOSL-5) D RTRN^ACHS Q:$D(DUOUT) D PHDR
.. W !?7,$P(^TMP("ACHSTX7X",$J,ACHSTOS,ACHSDIEN),U)
.. F %=1:1:4 I $P(^TMP("ACHSTX7X",$J,ACHSTOS,ACHSDIEN),U,%+1)=1 W ?45,$P($T(@("CHK"_%)),";",2) W:%=2 " ",$P(^TMP("ACHSTX7X",$J,ACHSTOS,ACHSDIEN),U,6) W !
..Q
.Q
Q:$D(DUOUT)
I $Y>(IOSL-8) D RTRN^ACHS Q:$D(DUOUT) D PHDR
W !!," TOTAL HOSPITAL DOCUMENTS WITH ERRORS = ",$J($FN(ACHSTOS(1),","),6)
W !!," TOTAL DENTAL DOCUMENTS WITH ERRORS = ",$J($FN(ACHSTOS(2),","),6)
W !!,"TOTAL OUTPATIENT DOCUMENTS WITH ERRORS = ",$J($FN(ACHSTOS(3),","),6),!
D RTRN^ACHS
Q
;
PHDR ; ----- Header for Report.
S ACHSPG=ACHSPG+1
W @IOF,!,$$LOC^ACHS,?70,"Page ",ACHSPG
W !,$$REPEAT^XLFSTR("-",80),!,$$C^XBFUNC($$DESC,80)
W !,$$C^XBFUNC("From Transaction Date "_$$FMTE^XLFDT(ACHSBDTS)_" to "_$$FMTE^XLFDT(ACHSEDT),80)
W !,$$REPEAT^XLFSTR("-",80)
W !!?5,"DOCUMENT NUMBER",?45,"TYPE OF ERROR",!?5,$$REPEAT^XLFSTR("-",15),?45,$$REPEAT^XLFSTR("-",13),!
Q
;
DESC() ;
Q $P($P($P($T(ACHSTX7X),";",2),"-",2)," ",2,7)
;
HELP ;EP - From DIR.
W !,$$C^XBFUNC($$DESC),!
F %=3:1 W !?5,$P($T(HELP+%),";",3) Q:$P($T(HELP+%+1),";",3)=""
;;This report will examine data in documents produced since your last
;;export, and produce a report listing any documents with missing or
;;invalid data, that is required by the Data center in Albuquerque.
;;
;;Checks include checking for valid ICD-9 codes, EIN vendor number,
;;Provider Type, and valid Admit/Discharge dates.
Q
;
ACHSTX7X ; IHS/ITSC/TPF/PMF - CHS TRIBAL STATISTICAL EXPORT ERROR REPORT ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22,23**;JUN 11, 2001;Build 43
+2 ;
+3 ; Produces report for incomplete data items for Statisitcal (638)
+4 ; records to be sent to DDPS.
+5 ;
+6 ; Sites can use the "Enter/Edit Medical Data" to fill in any
+7 ; missing ICD9 or APC codes, and the Vendor edit option to
+8 ; fill in an EIN or Vendor Type. Bad Admit/Discharge dates are
+9 ; rare and will have to be fixed w/FM.
+10 ;
+11 ; THANKS TO FONDA JACKSON OF PORTLAND FOR THE ORIGINAL ROUTINE.
+12 ;
+13 IF $$PARM^ACHS(0,8)'="Y"
WRITE !,"Your site is not a 638 facility."
DO RTRN^ACHS
QUIT
+14 ;
DEV ;
+1 SET %ZIS="MQP"
+2 DO ^%ZIS
+3 IF POP
GOTO CLOSE
+4 IF '$DATA(IO("Q"))
GOTO START
+5 SET ZTRTN="START^ACHSTX7X"
SET ZTDESC=$$DESC
+6 DO ^%ZTLOAD
DO HOME^%ZIS
+7 GOTO CLOSE
+8 ;
START ;EP - From TaskMan.
+1 KILL ^TMP("ACHSTX7X",$JOB)
+2 NEW ACHSBDTS,ACHSEIN,ACHSFC,ACHSFYDT
+3 DO SETUP
+4 DO CALC
+5 DO PRINT
+6 DO CLOSE
+7 QUIT
+8 ;
SETUP ; ----- Set vars. --------------------------------------------------
+1 DO FY^ACHSUF
DO FC^ACHSUF
+2 SET (ACHSDCR,ACHSBDT)=0
SET ACHSEDT=DT
+3 SET X=$ORDER(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",0))
+4 IF X?7N
Begin DoDot:1
+5 SET ACHSDCR=$ORDER(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",X,ACHSDCR))
+6 SET ACHSEDT=$PIECE(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSDCR,0),U,2)
+7 SET ACHSBDT=$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSDCR-1,0)),U,2)
+8 IF ACHSBDT'?7N
SET ACHSBDT=ACHSFYDT-10000
+9 QUIT
End DoDot:1
+10 IF ACHSDCR=0
SET ACHSBDT=ACHSFYDT-10000
+11 SET ACHSBDTS=ACHSBDT
+12 QUIT
+13 ;
CALC ; ----- Check for documents with incomplete data items. ------------
+1 FOR
SET ACHSBDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT))
IF (ACHSBDT>ACHSEDT)!(ACHSBDT'?7N)
QUIT
Begin DoDot:1
+2 IF '$DATA(^ACHSF(DUZ(2),"TB",ACHSBDT,"P"))
QUIT
+3 SET ACHSDIEN=0
+4 FOR
SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,"P",ACHSDIEN))
IF ACHSDIEN'?1N.N
QUIT
Begin DoDot:2
+5 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)
QUIT
+6 SET ACHSTIEN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,"P",ACHSDIEN,0))
+7 SET ACHSDOCR=^ACHSF(DUZ(2),"D",ACHSDIEN,0)
SET ACHSTOS=$PIECE(ACHSDOCR,U,4)
+8 DO CHK
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
CHK ; --- Text at CHK_ labels are used in report.
+1 FOR %=1:1:4
SET ACHSERR(%)=0
+2 SET ACHSTST=0
CHK1 ;ERROR IN ICD-9 CODE; Error 1.
+1 ;ACHS*3.1*23 ONLY TST ICD9 TYPE
IF ($$PARM^ACHS(0,18)-1)<$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,10)
GOTO CHK2
+2 DO DXPX^ACHSTX7A
+3 ;I ACHSTOS=1,+ACHSDX(1)<1 S ACHSERR(1)=1,ACHSTST=1 G CHK2
+4 IF ACHSTOS=1
IF '(+ACHSDX(1)>0)
IF "EV"'[$EXTRACT(ACHSDX(1))
SET ACHSERR(1)=1
SET ACHSTST=1
GOTO CHK2
+5 IF ACHSTOS=2
GOTO CHK2
+6 IF ACHSTOS=3
IF +ACHSAPC(1)<1
SET ACHSERR(1)=1
SET ACHSTST=1
CHK2 ;INVALID EIN; Error 2.
+1 IF '$PIECE(ACHSDOCR,U,8)
SET ACHSERR(2)=1
SET ACHSTST=1
SET ACHSEIN=""
GOTO CHK4
+2 SET (ACHSEIN,X)=$PIECE($GET(^AUTTVNDR($PIECE(ACHSDOCR,U,8),11)),U)
+3 XECUTE $PIECE(^DD(9999999.11,1101,0),U,5,99)
+4 IF '$DATA(X)
SET ACHSERR(2)=1
SET ACHSTST=1
GOTO CHK3
+5 IF "12"'[$EXTRACT(X)
SET ACHSERR(2)=1
SET ACHSTST=1
CHK3 ;INVALID PROVIDER TYPE; Error 3.
+1 SET X=$PIECE($GET(^AUTTVNDR($PIECE(ACHSDOCR,U,8),11)),U,3)
+2 IF X<1
SET ACHSERR(3)=1
SET ACHSTST=1
+3 IF X
IF '$DATA(^AUTTVTYP(X,0))
SET ACHSERR(3)=1
SET ACHSTST=1
CHK4 ;INVALID ADMISSION/DISCHARGE DATE; Error 4.
+1 IF ACHSTOS=1
Begin DoDot:1
+2 SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,2)
+3 SET Y=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,3)
+4 ;ACHS*3.1*22 IHS.OIT.FCJ MODIFIED TO TEST ADM DT > DISCHARGE DT
+5 ;S:(Y>ACHSBDT)!(Y>ACHSEDT)!(X>ACHSEDT)!(X'?7N)!(Y'?7N) ACHSERR(4)=1,ACHSTST=1
+6 IF (Y<X)!(X'?7N)!(Y'?7N)!($PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U)>Y)!(X<$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U))
SET ACHSERR(4)=1
SET ACHSTST=1
+7 QUIT
End DoDot:1
CHKEND ; ----- Set TMP Global with document Errors.
+1 IF ACHSTST=0
QUIT
+2 SET ^TMP("ACHSTX7X",$JOB,ACHSTOS,ACHSDIEN)=$PIECE(ACHSDOCR,U,14)_"-"_ACHSFC_"-"_$PIECE(ACHSDOCR,U)
+3 FOR %=1:1:4
SET $PIECE(^TMP("ACHSTX7X",$JOB,ACHSTOS,ACHSDIEN),U,%+1)=ACHSERR(%)
+4 SET $PIECE(^TMP("ACHSTX7X",$JOB,ACHSTOS,ACHSDIEN),U,6)=ACHSEIN
+5 QUIT
+6 ;
CLOSE ; ----- Close device, kill vars, quit. -----------------------------
+1 DO ^%ZISC
+2 KILL ACHSTOS,ACHSDX,ACHSAPC,ACHSERR,ACHSTST,ACHSDOCR,ACHSDIEN,ACHSTIEN,ACHSPX,ACHSCFY,ACHSX,ACHSY,ACHSPG,R,ACHSBDT,ACHSDCR,ACHS,ACHSEDT,^TMP("ACHSTX7X",$JOB)
+3 QUIT
+4 ;
PRINT ; ----- Print Errors. ----------------------------------------------
+1 USE IO
+2 SET ACHSPG=0
+3 DO PHDR
+4 SET (ACHSTOS(1),ACHSTOS(2),ACHSTOS(3))=0
+5 IF $DATA(^TMP("ACHSTX7X",$JOB))
Begin DoDot:1
+6 FOR ACHSTOS=1,2,3
SET ACHSDIEN=0
FOR
SET ACHSDIEN=$ORDER(^TMP("ACHSTX7X",$JOB,ACHSTOS,ACHSDIEN))
IF ACHSDIEN'?1N.N
QUIT
Begin DoDot:2
+7 SET ACHSTOS(ACHSTOS)=ACHSTOS(ACHSTOS)+1
+8 IF $Y>(IOSL-5)
DO RTRN^ACHS
IF $DATA(DUOUT)
QUIT
DO PHDR
+9 WRITE !?7,$PIECE(^TMP("ACHSTX7X",$JOB,ACHSTOS,ACHSDIEN),U)
+10 FOR %=1:1:4
IF $PIECE(^TMP("ACHSTX7X",$JOB,ACHSTOS,ACHSDIEN),U,%+1)=1
WRITE ?45,$PIECE($TEXT(@("CHK"_%)),";",2)
IF %=2
WRITE " ",$PIECE(^TMP("ACHSTX7X",$JOB,ACHSTOS,ACHSDIEN),U,6)
WRITE !
+11 QUIT
End DoDot:2
IF $DATA(DUOUT)
QUIT
+12 QUIT
End DoDot:1
+13 IF $DATA(DUOUT)
QUIT
+14 IF $Y>(IOSL-8)
DO RTRN^ACHS
IF $DATA(DUOUT)
QUIT
DO PHDR
+15 WRITE !!," TOTAL HOSPITAL DOCUMENTS WITH ERRORS = ",$JUSTIFY($FNUMBER(ACHSTOS(1),","),6)
+16 WRITE !!," TOTAL DENTAL DOCUMENTS WITH ERRORS = ",$JUSTIFY($FNUMBER(ACHSTOS(2),","),6)
+17 WRITE !!,"TOTAL OUTPATIENT DOCUMENTS WITH ERRORS = ",$JUSTIFY($FNUMBER(ACHSTOS(3),","),6),!
+18 DO RTRN^ACHS
+19 QUIT
+20 ;
PHDR ; ----- Header for Report.
+1 SET ACHSPG=ACHSPG+1
+2 WRITE @IOF,!,$$LOC^ACHS,?70,"Page ",ACHSPG
+3 WRITE !,$$REPEAT^XLFSTR("-",80),!,$$C^XBFUNC($$DESC,80)
+4 WRITE !,$$C^XBFUNC("From Transaction Date "_$$FMTE^XLFDT(ACHSBDTS)_" to "_$$FMTE^XLFDT(ACHSEDT),80)
+5 WRITE !,$$REPEAT^XLFSTR("-",80)
+6 WRITE !!?5,"DOCUMENT NUMBER",?45,"TYPE OF ERROR",!?5,$$REPEAT^XLFSTR("-",15),?45,$$REPEAT^XLFSTR("-",13),!
+7 QUIT
+8 ;
DESC() ;
+1 QUIT $PIECE($PIECE($PIECE($TEXT(ACHSTX7X),";",2),"-",2)," ",2,7)
+2 ;
HELP ;EP - From DIR.
+1 WRITE !,$$C^XBFUNC($$DESC),!
+2 FOR %=3:1
WRITE !?5,$PIECE($TEXT(HELP+%),";",3)
IF $PIECE($TEXT(HELP+%+1),";",3)=""
QUIT
+3 ;;This report will examine data in documents produced since your last
+4 ;;export, and produce a report listing any documents with missing or
+5 ;;invalid data, that is required by the Data center in Albuquerque.
+6 ;;
+7 ;;Checks include checking for valid ICD-9 codes, EIN vendor number,
+8 ;;Provider Type, and valid Admit/Discharge dates.
+9 QUIT
+10 ;
