ACHSIC3.m

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