ACHSIC3 ; IHS/ITSC/FCJ - REPORT FOR PO WITH ICD ERRORS AND CORRECTIONS;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22,23**;JUN 11, 2001;Build 43
;FIRST VERSION WITH POSSIBLE ERRORS....
;
;
ST ;
I '$D(^ACHSICD(DUZ(2),"D")) W !?5,"THERE ARE NOT ANY ICD ERRORS FOUND FOR THIS FACILITY" Q
S ACHSIO=IO
K X2,X3
W !!,"REPORT FOR DOCUMENTS WITH 3 DIGIT ICD CODE ERRORS."
W !,"This report is for FI processed PO's only. After the ICD file is processed"
W !,"from the FI, this report will display the PO and ICD codes that were changed."
;
DEV ;
S %=$$PB^ACHS
I %=U!$D(DTOUT)!$D(DUOUT) D K Q
;ACHS*3.1*23 CHNG RTN TO ACHSIC3
I %="B" D VIEWR^XBLM("PRINT^ACHSIC3"),EN^XBVK("VALM"),K Q
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS G K
G:'$D(IO("Q")) PRINT
K IO("Q")
I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
S ZTRTN="PRINT^ACHSDST",ZTIO="",ZTDESC=$P($T(TITLE),";",3),ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
F ACHS="ACHSQIO","ACHSRPT" S ZTSAVE(ACHS)=""
D ^%ZTLOAD
G:'$D(ZTSK) DEV
K ;
K ACHS,ACHSIO,ACHSQIO,ACHSBDT,ACHSEDT,ACHSRPT,ZTIO,ZTSK
D ^%ZISC
Q
;
PRINT ;EP - From TaskMan.
;
D FC^ACHSUF
I $D(ACHSERR),ACHSERR=1 K ZTSK G KILL
D BRPT^ACHSFU
D HDR
S X3=0
A ; Main loop.
S L=DUZ(2),L1=0,CT=0,ACHSQ=0
F S L1=$O(^ACHSICD(L,"D",L1)) Q:L1'?1N.N D Q:ACHSQ
.S L2=0 F S L2=$O(^ACHSICD(L,"D",L1,9,L2)) Q:L2'?1N.N D Q:ACHSQ
..S ICD2=$P(^ACHSICD(L,"D",L1,9,L2,0),U)
..S ICD3=$P(^ACHSICD(L,"D",L1,9,L2,0),U,3)
..S ACHSREC=^ACHSF(L,"D",L1,0),DA=L1
..D B
G END
;
B ;
S CT=CT+1
S ACHSDOC1=$P(ACHSREC,U),ACHSVPTR=$P(ACHSREC,U,8),ACHSDOC2=$P(ACHSREC,U,14)
G A:ACHSVPTR']"",A:'$D(^AUTTVNDR(ACHSVPTR,0)) S ACHSVNDR=$P(^(0),U)
S ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
K ACHSNAME
S DFN=$P(ACHSREC,U,22) I +DFN>0,$D(^DPT(DFN,0)) S ACHSNAME=$P(^(0),U)
I '$D(ACHSNAME) S ACHSNAME=$S($P(ACHSREC,U,2)=1:"* BLANKET",1:"* SPECIAL TRANS")
E ;
S ACHSIDT=$P(ACHSREC,U,2)
W $E(ACHSNAME,1,24),?25,$E(ACHSVNDR,1,26),?52,$E(ACHSIDT,4,7),$E(ACHSIDT,2,3)
;W !,ACHSDOC,?25,$P($$ICDDX^ICDCODE(ICD2),U,2),?52,$P($$ICDDX^ICDCODE(ICD3),U,2) ;ACHS*3.1*23
W !,ACHSDOC,?25,$P($$ICDDX^ICDEX(ICD2),U,2),?52,$P($$ICDDX^ICDEX(ICD3),U,2) ;ACHS*3.1*23
;W ?80-$L(X),X
P3 ; Ask RTRN if EOP, do header, go main loop.
W !!
I $Y>ACHSBM D RTRN^ACHS S:$D(DUOUT)!$D(DTOUT) ACHSQ=1 Q:ACHSQ D HDR
Q
;
END ; Print totals, ask RTRN, write IOF.
W @IOF
W !!,"TOTAL UPDATES = ",CT,!
D RTRN^ACHS
KILL ; Do ERPT, kill vars, quit.
I $D(ZTQUEUED) K ACHSFC
K ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSTYPE,ACHSVNDR,ACHSEIN,ACHSOPEN,ACHSNAME,ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVPTR,AZUCHSCAN
K CT,ACHSREC,ACHSQ,ACHSQUIT,DA,DFN,X2,X3
Q
;
HDR ; Print report header.
S ACHSPG=ACHSPG+1
W @IOF,!!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,$$C^XBFUNC("*** CONTRACT HEALTH MANAGEMENT SYSTEM ***",80),!!,ACHSLOC,!?24,"ICD 3 digit Purchase Order Report"
I $D(ZTQUEUED) W ?77-$L(ZTSK),"(",ZTSK,")"
W !,ACHSTIME,!!,"Patient Name",?25,"Provider of Service",?52,"Issue"
W !,"Document number",?25,"DX CODE",?52,"NEW DX CODE",!,$$REPEAT^XLFSTR("=",79),!
Q
;
TITLE ;;ICD UPDATED DOCUMENTS FROM ICD CODE ERROR
ACHSIC3 ; IHS/ITSC/FCJ - REPORT FOR PO WITH ICD ERRORS AND CORRECTIONS;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22,23**;JUN 11, 2001;Build 43
+2 ;FIRST VERSION WITH POSSIBLE ERRORS....
+3 ;
+4 ;
ST ;
+1 IF '$DATA(^ACHSICD(DUZ(2),"D"))
WRITE !?5,"THERE ARE NOT ANY ICD ERRORS FOUND FOR THIS FACILITY"
QUIT
+2 SET ACHSIO=IO
+3 KILL X2,X3
+4 WRITE !!,"REPORT FOR DOCUMENTS WITH 3 DIGIT ICD CODE ERRORS."
+5 WRITE !,"This report is for FI processed PO's only. After the ICD file is processed"
+6 WRITE !,"from the FI, this report will display the PO and ICD codes that were changed."
+7 ;
DEV ;
+1 SET %=$$PB^ACHS
+2 IF %=U!$DATA(DTOUT)!$DATA(DUOUT)
DO K
QUIT
+3 ;ACHS*3.1*23 CHNG RTN TO ACHSIC3
+4 IF %="B"
DO VIEWR^XBLM("PRINT^ACHSIC3")
DO EN^XBVK("VALM")
DO K
QUIT
+5 SET %ZIS="OPQ"
+6 DO ^%ZIS
+7 IF POP
DO HOME^%ZIS
GOTO K
+8 IF '$DATA(IO("Q"))
GOTO PRINT
+9 KILL IO("Q")
+10 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+11 SET ZTRTN="PRINT^ACHSDST"
SET ZTIO=""
SET ZTDESC=$PIECE($TEXT(TITLE),";",3)
SET ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
+12 FOR ACHS="ACHSQIO","ACHSRPT"
SET ZTSAVE(ACHS)=""
+13 DO ^%ZTLOAD
+14 IF '$DATA(ZTSK)
GOTO DEV
K ;
+1 KILL ACHS,ACHSIO,ACHSQIO,ACHSBDT,ACHSEDT,ACHSRPT,ZTIO,ZTSK
+2 DO ^%ZISC
+3 QUIT
+4 ;
PRINT ;EP - From TaskMan.
+1 ;
+2 DO FC^ACHSUF
+3 IF $DATA(ACHSERR)
IF ACHSERR=1
KILL ZTSK
GOTO KILL
+4 DO BRPT^ACHSFU
+5 DO HDR
+6 SET X3=0
A ; Main loop.
+1 SET L=DUZ(2)
SET L1=0
SET CT=0
SET ACHSQ=0
+2 FOR
SET L1=$ORDER(^ACHSICD(L,"D",L1))
IF L1'?1N.N
QUIT
Begin DoDot:1
+3 SET L2=0
FOR
SET L2=$ORDER(^ACHSICD(L,"D",L1,9,L2))
IF L2'?1N.N
QUIT
Begin DoDot:2
+4 SET ICD2=$PIECE(^ACHSICD(L,"D",L1,9,L2,0),U)
+5 SET ICD3=$PIECE(^ACHSICD(L,"D",L1,9,L2,0),U,3)
+6 SET ACHSREC=^ACHSF(L,"D",L1,0)
SET DA=L1
+7 DO B
End DoDot:2
IF ACHSQ
QUIT
End DoDot:1
IF ACHSQ
QUIT
+8 GOTO END
+9 ;
B ;
+1 SET CT=CT+1
+2 SET ACHSDOC1=$PIECE(ACHSREC,U)
SET ACHSVPTR=$PIECE(ACHSREC,U,8)
SET ACHSDOC2=$PIECE(ACHSREC,U,14)
+3 IF ACHSVPTR']""
GOTO A
IF '$DATA(^AUTTVNDR(ACHSVPTR,0))
GOTO A
SET ACHSVNDR=$PIECE(^(0),U)
+4 SET ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
+5 KILL ACHSNAME
+6 SET DFN=$PIECE(ACHSREC,U,22)
IF +DFN>0
IF $DATA(^DPT(DFN,0))
SET ACHSNAME=$PIECE(^(0),U)
+7 IF '$DATA(ACHSNAME)
SET ACHSNAME=$SELECT($PIECE(ACHSREC,U,2)=1:"* BLANKET",1:"* SPECIAL TRANS")
E ;
+1 SET ACHSIDT=$PIECE(ACHSREC,U,2)
+2 WRITE $EXTRACT(ACHSNAME,1,24),?25,$EXTRACT(ACHSVNDR,1,26),?52,$EXTRACT(ACHSIDT,4,7),$EXTRACT(ACHSIDT,2,3)
+3 ;W !,ACHSDOC,?25,$P($$ICDDX^ICDCODE(ICD2),U,2),?52,$P($$ICDDX^ICDCODE(ICD3),U,2) ;ACHS*3.1*23
+4 ;ACHS*3.1*23
WRITE !,ACHSDOC,?25,$PIECE($$ICDDX^ICDEX(ICD2),U,2),?52,$PIECE($$ICDDX^ICDEX(ICD3),U,2)
+5 ;W ?80-$L(X),X
P3 ; Ask RTRN if EOP, do header, go main loop.
+1 WRITE !!
+2 IF $Y>ACHSBM
DO RTRN^ACHS
IF $DATA(DUOUT)!$DATA(DTOUT)
SET ACHSQ=1
IF ACHSQ
QUIT
DO HDR
+3 QUIT
+4 ;
END ; Print totals, ask RTRN, write IOF.
+1 WRITE @IOF
+2 WRITE !!,"TOTAL UPDATES = ",CT,!
+3 DO RTRN^ACHS
KILL ; Do ERPT, kill vars, quit.
+1 IF $DATA(ZTQUEUED)
KILL ACHSFC
+2 KILL ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSTYPE,ACHSVNDR,ACHSEIN,ACHSOPEN,ACHSNAME,ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVPTR,AZUCHSCAN
+3 KILL CT,ACHSREC,ACHSQ,ACHSQUIT,DA,DFN,X2,X3
+4 QUIT
+5 ;
HDR ; Print report header.
+1 SET ACHSPG=ACHSPG+1
+2 WRITE @IOF,!!,ACHSUSR,?71,"Page",$JUSTIFY(ACHSPG,3),!,$$C^XBFUNC("*** CONTRACT HEALTH MANAGEMENT SYSTEM ***",80),!!,ACHSLOC,!?24,"ICD 3 digit Purchase Order Report"
+3 IF $DATA(ZTQUEUED)
WRITE ?77-$LENGTH(ZTSK),"(",ZTSK,")"
+4 WRITE !,ACHSTIME,!!,"Patient Name",?25,"Provider of Service",?52,"Issue"
+5 WRITE !,"Document number",?25,"DX CODE",?52,"NEW DX CODE",!,$$REPEAT^XLFSTR("=",79),!
+6 QUIT
+7 ;
TITLE ;;ICD UPDATED DOCUMENTS FROM ICD CODE ERROR
