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
Q
;
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
;
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)
Q
;
W !?4,"Vendor: ",ACHSVNDR,!!?3,"# CODE #",?39,"# DOCS #",?52,"$ OBLIG $",?66,"$ PAYMENT $",!
Q
;
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 ;
+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 ;
+1 WRITE !?4,"Vendor: ",ACHSVNDR,!!?3,"# CODE #",?39,"# DOCS #",?52,"$ OBLIG $",?66,"$ PAYMENT $",!
+2 QUIT
+3 ;
