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
;
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
;
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 ;
+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 ;
+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 ;
