Routine: ACHSOCVS

ACHSOCVS ; IHS/ITSC/PMF - SUMMARY ONLY PRT OBJCLAS CODE-VENDOR ;  [ 10/16/2001   8:16 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 D BRPT^ACHSFU

 S ACHSFAC=DUZ(2)

 S (ACHSOB,ACHSPAGE,C,ACHSOBST,ACHSPMST,ACHSDOCS,ACHSOBT,ACHSPMTT,ACHSDOCT,ACHSDOC,ACHSOBGT,ACHSPMGT,ACHSDGT)=0

 I $D(^TMP("ACHSOCV",$J,ACHSFAC,0)) S C=0 G NODATA

 S ACHSVNDR=""

P1 ;

 S ACHSVNDR=$O(^TMP("ACHSOCV",$J,ACHSFAC,ACHSVNDR))

 G TOTL:ACHSVNDR=""

 D HEADER,HEADER1

 S ACHSOC=""

P2 ;

 S ACHSOC=$O(^TMP("ACHSOCV",$J,ACHSFAC,ACHSVNDR,ACHSOC))

 G:ACHSOC="" SUBTOTL

 S ACHSDOC=""

 S ACHSDOCS=$P(^TMP("ACHSOCV",$J,ACHSFAC,ACHSVNDR,ACHSOC),U,1),ACHSOBST=$P(^(ACHSOC),U,2),ACHSPMST=$P(^(ACHSOC),U,3)

 S ACHSOCD=$E($P(^ACHS(3,ACHSFAC,1,ACHSOC,0),U,1),1,2)_"."_$E($P(^ACHS(3,ACHSFAC,1,ACHSOC,0),U,1),3,4),ACHSOCD=ACHSOCD_" -"_$S($P(^ACHS(3,ACHSFAC,1,ACHSOC,0),U,2)]"":$P(^(0),U,2),1:"NOT ON FILE")

PRINT ;Prints data totals

 W !?4,ACHSOCD,?39,$J(ACHSDOCS,4)

 S X=ACHSOBST,X2=2

 D COMMA^%DTC

 W ?50,X

 S X=ACHSPMST,X2=2

 D COMMA^%DTC

 W ?66,X

 I IOST["P-",$Y>56 D HEADER,HEADER1

 I IOST["C-",'$D(IO("S")),$Y>24 W !! G END:'$$DIR^XBDIR("E") D HEADER,HEADER1

 S ACHSOBT=ACHSOBT+ACHSOBST,ACHSPMTT=ACHSPMTT+ACHSPMST,ACHSDOCT=ACHSDOCT+ACHSDOCS

 S (ACHSOBST,ACHSDOCS,ACHSPMST,C)=0

 G P2

SUBTOTL ;

 W !!,$$REPEAT^XLFSTR("-",80),!?3,"SUBTOTAL",?39,$J(ACHSDOCT,4)

 S X=ACHSOBT,X2="2$"

 D COMMA^%DTC

 W ?50,X

 S X=ACHSPMTT,X2="2$"

 D COMMA^%DTC

 W ?66,X

 I ACHSOBT>0,ACHSPMTT>0 S X=(ACHSPMTT/ACHSOBT)*100 W !!?3,"PERCENTAGE OF PAYMENT TO OBLIGATED" W ?63,$E(X,1,5)_"%"

 S ACHSOBGT=ACHSOBGT+ACHSOBT,ACHSPMGT=ACHSPMGT+ACHSPMTT,ACHSDGT=ACHSDGT+ACHSDOCT

 I IOST["C-",'$D(IO("S")) W !! G END:'$$DIR^XBDIR("E")

 S (C,ACHSOBT,ACHSPMTT,ACHSDOCT,ACHSPAGE)=0

 G P1

TOTL ;

 W !!!!,$$REPEAT^XLFSTR("=",80),!!?3,"TOTAL",?39,$J(ACHSDGT,4)

 S X=ACHSOBGT,X2="2$"

 D COMMA^%DTC

 W ?50,X

 S X=ACHSPMGT,X2="2$"

 D COMMA^%DTC

 W ?66,X

 I ACHSOBGT>0,ACHSPMGT>0 S X=(ACHSPMGT/ACHSOBGT)*100 W !!?3,"PERCENTAGE OF PAYMENT TO OBLIGATED" W ?63,$E(X,1,5)_"%"

 I IOST["C-",'$D(IO("S")) W !! G END:'$$DIR^XBDIR("E")

END ;

 S:$D(ZTQUEUED) ZTREQ="@"

 D ^%ZISC,EN^XBVK("ACHS"),^ACHSVAR

 K C,I,X,X2,Y,^TMP("ACHSOCV",$J),DIR

NODATA ;

 D HEADER

 W !!!,"NO DATA FOR SPECIFIED FISCAL YEAR",!!!!

 I IOST["C-",'$D(IO("S")) G END:'$$DIR^XBDIR("E")

 K ^TMP("ACHSOCV",$J,ACHSFAC,0)

 G END

HEADER ;Prints heading

 U IO

 W @IOF

 S ACHSPAGE=ACHSPAGE+1

 S Y=$$HTE^XLFDT($H),ACHSDAT=$P(Y,"@",1),ACHSTIM=$P(Y,"@",2)

 W !,"*",ACHSDAT

 S X=$$LOC^ACHS

 W ?((80/2)-($L(X)/2)),X

 W ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*"

 S X="SERVICE CLASSIFICATION Summary Report BY VENDOR - Page "

 W !!?((80/2)-($L(X)/2)),X_ACHSPAGE

 S X="For FISCAL YEAR: "

 W !?((80/2)-($L(X)/2)),X_ACHSFY,!,$$REPEAT^XLFSTR("*",80)

HEADER1 ;Prints Vendor

 W !?4,"Vendor: ",ACHSVNDR,!!?3,"# CODE #",?39,"# DOCS #",?52,"$ OBLIG $",?66,"$ PAYMENT $",!

ACHSOCVS  ; IHS/ITSC/PMF - SUMMARY ONLY PRT OBJCLAS CODE-VENDOR ;  [ 10/16/2001   8:16 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 +2       ;

 +3        DO BRPT^ACHSFU

 +4        SET ACHSFAC=DUZ(2)

 +5        SET (ACHSOB,ACHSPAGE,C,ACHSOBST,ACHSPMST,ACHSDOCS,ACHSOBT,ACHSPMTT,ACHSDOCT,ACHSDOC,ACHSOBGT,ACHSPMGT,ACHSDGT)=0

 +6        IF $DATA(^TMP("ACHSOCV",$JOB,ACHSFAC,0))

               SET C=0

               GOTO NODATA

 +7        SET ACHSVNDR=""

P1        ;

 +1        SET ACHSVNDR=$ORDER(^TMP("ACHSOCV",$JOB,ACHSFAC,ACHSVNDR))

 +2        IF ACHSVNDR=""

               GOTO TOTL

 +3        DO HEADER

           DO HEADER1

 +4        SET ACHSOC=""

P2        ;

 +1        SET ACHSOC=$ORDER(^TMP("ACHSOCV",$JOB,ACHSFAC,ACHSVNDR,ACHSOC))

 +2        IF ACHSOC=""

               GOTO SUBTOTL

 +3        SET ACHSDOC=""

 +4        SET ACHSDOCS=$PIECE(^TMP("ACHSOCV",$JOB,ACHSFAC,ACHSVNDR,ACHSOC),U,1)

           SET ACHSOBST=$PIECE(^(ACHSOC),U,2)

           SET ACHSPMST=$PIECE(^(ACHSOC),U,3)

 +5        SET ACHSOCD=$EXTRACT($PIECE(^ACHS(3,ACHSFAC,1,ACHSOC,0),U,1),1,2)_"."_$EXTRACT($PIECE(^ACHS(3,ACHSFAC,1,ACHSOC,0),U,1),3,4)

           SET ACHSOCD=ACHSOCD_" -"_$SELECT($PIECE(^ACHS(3,ACHSFAC,1,ACHSOC,0),U,2)]"":$PIECE(^(0),U,2),1:"NOT ON FILE")

PRINT     ;Prints data totals

 +1        WRITE !?4,ACHSOCD,?39,$JUSTIFY(ACHSDOCS,4)

 +2        SET X=ACHSOBST

           SET X2=2

 +3        DO COMMA^%DTC

 +4        WRITE ?50,X

 +5        SET X=ACHSPMST

           SET X2=2

 +6        DO COMMA^%DTC

 +7        WRITE ?66,X

 +8        IF IOST["P-"

               IF $Y>56

                   DO HEADER

                   DO HEADER1

 +9        IF IOST["C-"

               IF '$DATA(IO("S"))

                   IF $Y>24

                       WRITE !!

                       IF '$$DIR^XBDIR("E")

                           GOTO END

                       DO HEADER

                       DO HEADER1

 +10       SET ACHSOBT=ACHSOBT+ACHSOBST

           SET ACHSPMTT=ACHSPMTT+ACHSPMST

           SET ACHSDOCT=ACHSDOCT+ACHSDOCS

 +11       SET (ACHSOBST,ACHSDOCS,ACHSPMST,C)=0

 +12       GOTO P2

 +13      ;

SUBTOTL   ;

 +1        WRITE !!,$$REPEAT^XLFSTR("-",80),!?3,"SUBTOTAL",?39,$JUSTIFY(ACHSDOCT,4)

 +2        SET X=ACHSOBT

           SET X2="2$"

 +3        DO COMMA^%DTC

 +4        WRITE ?50,X

 +5        SET X=ACHSPMTT

           SET X2="2$"

 +6        DO COMMA^%DTC

 +7        WRITE ?66,X

 +8        IF ACHSOBT>0

               IF ACHSPMTT>0

                   SET X=(ACHSPMTT/ACHSOBT)*100

                   WRITE !!?3,"PERCENTAGE OF PAYMENT TO OBLIGATED"

                   WRITE ?63,$EXTRACT(X,1,5)_"%"

 +9        SET ACHSOBGT=ACHSOBGT+ACHSOBT

           SET ACHSPMGT=ACHSPMGT+ACHSPMTT

           SET ACHSDGT=ACHSDGT+ACHSDOCT

 +10       IF IOST["C-"

               IF '$DATA(IO("S"))

                   WRITE !!

                   IF '$$DIR^XBDIR("E")

                       GOTO END

 +11       SET (C,ACHSOBT,ACHSPMTT,ACHSDOCT,ACHSPAGE)=0

 +12       GOTO P1

 +13      ;

TOTL      ;

 +1        WRITE !!!!,$$REPEAT^XLFSTR("=",80),!!?3,"TOTAL",?39,$JUSTIFY(ACHSDGT,4)

 +2        SET X=ACHSOBGT

           SET X2="2$"

 +3        DO COMMA^%DTC

 +4        WRITE ?50,X

 +5        SET X=ACHSPMGT

           SET X2="2$"

 +6        DO COMMA^%DTC

 +7        WRITE ?66,X

 +8        IF ACHSOBGT>0

               IF ACHSPMGT>0

                   SET X=(ACHSPMGT/ACHSOBGT)*100

                   WRITE !!?3,"PERCENTAGE OF PAYMENT TO OBLIGATED"

                   WRITE ?63,$EXTRACT(X,1,5)_"%"

 +9        IF IOST["C-"

               IF '$DATA(IO("S"))

                   WRITE !!

                   IF '$$DIR^XBDIR("E")

                       GOTO END

END       ;

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        DO ^%ZISC

           DO EN^XBVK("ACHS")

           DO ^ACHSVAR

 +3        KILL C,I,X,X2,Y,^TMP("ACHSOCV",$JOB),DIR

 +4        QUIT

 +5       ;

NODATA    ;

 +1        DO HEADER

 +2        WRITE !!!,"NO DATA FOR SPECIFIED FISCAL YEAR",!!!!

 +3        IF IOST["C-"

               IF '$DATA(IO("S"))

                   IF '$$DIR^XBDIR("E")

                       GOTO END

 +4        KILL ^TMP("ACHSOCV",$JOB,ACHSFAC,0)

 +5        GOTO END

 +6       ;

HEADER    ;Prints heading

 +1        USE IO

 +2        WRITE @IOF

 +3        SET ACHSPAGE=ACHSPAGE+1

 +4        SET Y=$$HTE^XLFDT($HOROLOG)

           SET ACHSDAT=$PIECE(Y,"@",1)

           SET ACHSTIM=$PIECE(Y,"@",2)

 +5        WRITE !,"*",ACHSDAT

 +6        SET X=$$LOC^ACHS

 +7        WRITE ?((80/2)-($LENGTH(X)/2)),X

 +8        WRITE ?71,ACHSTIM,"*",!,"*User: ",ACHSUSR,?70,"Device:",IO,"*"

 +9        SET X="SERVICE CLASSIFICATION Summary Report BY VENDOR - Page "

 +10       WRITE !!?((80/2)-($LENGTH(X)/2)),X_ACHSPAGE

 +11       SET X="For FISCAL YEAR: "

 +12       WRITE !?((80/2)-($LENGTH(X)/2)),X_ACHSFY,!,$$REPEAT^XLFSTR("*",80)

 +13       QUIT

 +14      ;

HEADER1   ;Prints Vendor

 +1        WRITE !?4,"Vendor: ",ACHSVNDR,!!?3,"# CODE #",?39,"# DOCS #",?52,"$ OBLIG $",?66,"$ PAYMENT $",!

 +2        QUIT

 +3       ;

ACHSOCVS.m