ACHSOCVD.m

ACHSOCVD ; IHS/ITSC/PMF - DETAILED PRINT CHS 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),ACHSPAGE=0

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

 S (ACHSOB,C,ACHSOBST,ACHSPMST,ACHSDOCS,ACHSOBT,ACHSPMTT,ACHSDOCT,ACHSDOC,ACHSFLG,ACHSPAGE,ACHSVDCT,ACHSVOBT,ACHSVPMT)=0

 S ACHSVNDR=""

P2 ;

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

 G TOTL:ACHSVNDR=""

 S ACHSOC=""

P3 ;

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

 G:ACHSOC="" VNDRTOT

 D HEADER

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

 S ACHSDOC=""

P4 ;

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

 G:ACHSDOC="" SUBTOTL

GETADD ;Vendor address

 S ACHSVEN=$P(^TMP("ACHSOCV",$J,ACHSFAC,ACHSVNDR,ACHSOC,ACHSDOC),U,5),Z=$G(^AUTTVNDR(ACHSVEN,13))

 S ACHSVADD=$S(Z="":"NOT ON FILE",1:$P(Z,U,1)),ACHSVCIT=$S(Z="":Z,1:$P(Z,U,2)),ACHSVST=$S(Z="":Z,1:$P(Z,U,3)),ACHSVST=$S(ACHSVST="":ACHSVST,1:$P(^DIC(5,ACHSVST,0),U,1)),ACHSZIP=$S(Z="":Z,1:$P(Z,U,4))

 D:ACHSFLG=0 HEADER1

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

GETPAT ;

 S P=$P(X,U,1),ACHSPAT=$S(P]"":$P(^DPT(P,0),U,1),1:"No NAME on file")

GETHRN ;

 S ACHSHRN=$S($P(X,U,2)]"":$P(X,U,2),1:"NONE"),ACHSOB=$P(X,U,3),A=$P(X,U,4),ACHSPMT=$S(A="":0,1:A)

PRINT ;Prints data totals

 W !,ACHSDOC,?17,$E(ACHSPAT,1,25),?45,$J(ACHSHRN,6)

 S X=ACHSOB,X2=2

 D COMMA^%DTC

 W ?54,X

 S X=ACHSPMT,X2=2

 D COMMA^%DTC

 W ?68,X

 S ACHSOBST=ACHSOBST+ACHSOB,ACHSPMST=ACHSPMST+ACHSPMT,C=C+1,ACHSDOCS=C,ACHSFLG=1

 I IOST["P-",$Y>56 S ACHSFLG=1 D HEADER,HEADER1

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

 G P4

 ;

SUBTOTL ;

 W !!,$$REPEAT^XLFSTR("-",80),!,"SUBTOTAL",?25,$J(ACHSDOCS,4)

 S X=ACHSOBST,X2="2$"

 D COMMA^%DTC

 W ?54,X

 S X=ACHSPMST,X2="2$"

 D COMMA^%DTC

 W ?68,X

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

 I ACHSOBST>0,ACHSPMST>0 S X=(ACHSPMST/ACHSOBST)*100 W !!,"PERCENTAGE OF PAYMENT TO OBLIGATED" W ?67,$E(X,1,5)_"%"

 S ACHSVDCT=ACHSVDCT+ACHSDOCS,ACHSVOBT=ACHSVOBT+ACHSOBST,ACHSVPMT=ACHSVPMT+ACHSPMST

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

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

 G P3

 ;

VNDRTOT ;

 W !!,$$REPEAT^XLFSTR("=",80),!,"VENDOR TOTALS",?25,$J(ACHSVDCT,4)

 S X=ACHSVOBT,X2="2$"

 D COMMA^%DTC

 W ?54,X

 S X=ACHSVPMT,X2="2$"

 D COMMA^%DTC

 W ?68,X

 I ACHSVOBT>0,ACHSVPMT>0 S X=(ACHSVPMT/ACHSVOBT)*100 W !!,"PERCENTAGE OF PAYMENT TO OBLIGATED" W ?67,$E(X,1,5)_"%"

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

 S (ACHSVDCT,ACHSFLG,ACHSVOBT,ACHSVPMT,ACHSPAGE)=0

 G P2

 ;

TOTL ;

 W !!!!,$$REPEAT^XLFSTR("=",80),!!,"TOTAL",?25,$J(ACHSDOCT,4)

 S X=ACHSOBT,X2="2$"

 D COMMA^%DTC

 W ?56,X

 S X=ACHSPMTT,X2="2$"

 D COMMA^%DTC

 W ?68,X

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

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

END ;Close device, kill variables, quit

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

 D ^%ZISC

 K I,P,Z,X,X2,Y,^TMP("ACHSOCV",$J)

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

 Q

 ;

NODATA ;

 D HEADER

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

 I IOST["C-",'$D(IO("S")) Q:'$$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="Detailed SERVICE CLASSIFICATION 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)

 Q

 ;

HEADER1 ;Prints Object Class Code/Vendor Data

 W !!?5,"Object Class Code: ",ACHSOCD,!?16,"Vendor: ",ACHSVNDR,!?24,ACHSVADD,!?24,ACHSVCIT," ",?34,ACHSVST," ",?45,ACHSZIP,!!?1,"# DOCS #",?17,"PATIENT NAME",?44,"# CHART #",?56,"$ OBLIG $",?68,"$ PAYMENT $",!

 Q

 ;

ACHSOCVD  ; IHS/ITSC/PMF - DETAILED PRINT CHS 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)

           SET ACHSPAGE=0

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

               GOTO NODATA

 +6        SET (ACHSOB,C,ACHSOBST,ACHSPMST,ACHSDOCS,ACHSOBT,ACHSPMTT,ACHSDOCT,ACHSDOC,ACHSFLG,ACHSPAGE,ACHSVDCT,ACHSVOBT,ACHSVPMT)=0

 +7        SET ACHSVNDR=""

P2        ;

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

 +2        IF ACHSVNDR=""

               GOTO TOTL

 +3        SET ACHSOC=""

P3        ;

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

 +2        IF ACHSOC=""

               GOTO VNDRTOT

 +3        DO HEADER

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

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

 +5        SET ACHSDOC=""

P4        ;

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

 +2        IF ACHSDOC=""

               GOTO SUBTOTL

GETADD    ;Vendor address

 +1        SET ACHSVEN=$PIECE(^TMP("ACHSOCV",$JOB,ACHSFAC,ACHSVNDR,ACHSOC,ACHSDOC),U,5)

           SET Z=$GET(^AUTTVNDR(ACHSVEN,13))

 +2        SET ACHSVADD=$SELECT(Z="":"NOT ON FILE",1:$PIECE(Z,U,1))

           SET ACHSVCIT=$SELECT(Z="":Z,1:$PIECE(Z,U,2))

           SET ACHSVST=$SELECT(Z="":Z,1:$PIECE(Z,U,3))

           SET ACHSVST=$SELECT(ACHSVST="":ACHSVST,1:$PIECE(^DIC(5,ACHSVST,0),U,1))

           SET ACHSZIP=$SELECT(Z="":Z,1:$PIECE(Z,U,4))

 +3        IF ACHSFLG=0

               DO HEADER1

 +4        SET X=^TMP("ACHSOCV",$JOB,ACHSFAC,ACHSVNDR,ACHSOC,ACHSDOC)

GETPAT    ;

 +1        SET P=$PIECE(X,U,1)

           SET ACHSPAT=$SELECT(P]"":$PIECE(^DPT(P,0),U,1),1:"No NAME on file")

GETHRN    ;

 +1        SET ACHSHRN=$SELECT($PIECE(X,U,2)]"":$PIECE(X,U,2),1:"NONE")

           SET ACHSOB=$PIECE(X,U,3)

           SET A=$PIECE(X,U,4)

           SET ACHSPMT=$SELECT(A="":0,1:A)

PRINT     ;Prints data totals

 +1        WRITE !,ACHSDOC,?17,$EXTRACT(ACHSPAT,1,25),?45,$JUSTIFY(ACHSHRN,6)

 +2        SET X=ACHSOB

           SET X2=2

 +3        DO COMMA^%DTC

 +4        WRITE ?54,X

 +5        SET X=ACHSPMT

           SET X2=2

 +6        DO COMMA^%DTC

 +7        WRITE ?68,X

 +8        SET ACHSOBST=ACHSOBST+ACHSOB

           SET ACHSPMST=ACHSPMST+ACHSPMT

           SET C=C+1

           SET ACHSDOCS=C

           SET ACHSFLG=1

 +9        IF IOST["P-"

               IF $Y>56

                   SET ACHSFLG=1

                   DO HEADER

                   DO HEADER1

 +10       IF IOST["C-"

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

                   IF $Y>24

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

                           GOTO END

                       SET ACHSFLG=1

                       DO HEADER

                       DO HEADER1

 +11       GOTO P4

 +12      ;

SUBTOTL   ;

 +1        WRITE !!,$$REPEAT^XLFSTR("-",80),!,"SUBTOTAL",?25,$JUSTIFY(ACHSDOCS,4)

 +2        SET X=ACHSOBST

           SET X2="2$"

 +3        DO COMMA^%DTC

 +4        WRITE ?54,X

 +5        SET X=ACHSPMST

           SET X2="2$"

 +6        DO COMMA^%DTC

 +7        WRITE ?68,X

 +8        SET ACHSOBT=ACHSOBT+ACHSOBST

           SET ACHSPMTT=ACHSPMTT+ACHSPMST

           SET ACHSDOCT=ACHSDOCT+ACHSDOCS

 +9        IF ACHSOBST>0

               IF ACHSPMST>0

                   SET X=(ACHSPMST/ACHSOBST)*100

                   WRITE !!,"PERCENTAGE OF PAYMENT TO OBLIGATED"

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

 +10       SET ACHSVDCT=ACHSVDCT+ACHSDOCS

           SET ACHSVOBT=ACHSVOBT+ACHSOBST

           SET ACHSVPMT=ACHSVPMT+ACHSPMST

 +11       IF IOST["C-"

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

                   WRITE !!

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

                       GOTO END

 +12       SET (C,ACHSOBST,ACHSPMST,ACHSFLG,ACHSDOCS)=0

 +13       GOTO P3

 +14      ;

VNDRTOT   ;

 +1        WRITE !!,$$REPEAT^XLFSTR("=",80),!,"VENDOR TOTALS",?25,$JUSTIFY(ACHSVDCT,4)

 +2        SET X=ACHSVOBT

           SET X2="2$"

 +3        DO COMMA^%DTC

 +4        WRITE ?54,X

 +5        SET X=ACHSVPMT

           SET X2="2$"

 +6        DO COMMA^%DTC

 +7        WRITE ?68,X

 +8        IF ACHSVOBT>0

               IF ACHSVPMT>0

                   SET X=(ACHSVPMT/ACHSVOBT)*100

                   WRITE !!,"PERCENTAGE OF PAYMENT TO OBLIGATED"

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

 +9        IF IOST["C-"

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

                   WRITE !!

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

                       GOTO END

 +10       SET (ACHSVDCT,ACHSFLG,ACHSVOBT,ACHSVPMT,ACHSPAGE)=0

 +11       GOTO P2

 +12      ;

TOTL      ;

 +1        WRITE !!!!,$$REPEAT^XLFSTR("=",80),!!,"TOTAL",?25,$JUSTIFY(ACHSDOCT,4)

 +2        SET X=ACHSOBT

           SET X2="2$"

 +3        DO COMMA^%DTC

 +4        WRITE ?56,X

 +5        SET X=ACHSPMTT

           SET X2="2$"

 +6        DO COMMA^%DTC

 +7        WRITE ?68,X

 +8        IF ACHSOBT>0

               IF ACHSPMTT>0

                   SET X=(ACHSPMTT/ACHSOBT)*100

                   WRITE !!,"PERCENTAGE OF PAYMENT TO OBLIGATED"

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

 +9        IF IOST["C-"

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

                   WRITE !!

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

                       GOTO END

END       ;Close device, kill variables, quit

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        DO ^%ZISC

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

 +4        DO EN^XBVK("ACHS")

           DO ^ACHSVAR

 +5        QUIT 

 +6       ;

NODATA    ;

 +1        DO HEADER

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

 +3        IF IOST["C-"

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

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

                       QUIT 

 +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="Detailed SERVICE CLASSIFICATION 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 Object Class Code/Vendor Data

 +1        WRITE !!?5,"Object Class Code: ",ACHSOCD,!?16,"Vendor: ",ACHSVNDR,!?24,ACHSVADD,!?24,ACHSVCIT," ",?34,ACHSVST," ",?45,ACHSZIP,!!?1,"# DOCS #",?17,"PATIENT NAME",?44,"# CHART #",?56,"$ OBLIG $",?68,"$ PAYMENT $",!

 +2        QUIT 

 +3       ;