ACHSCPTH ; IHS/ITSC/PMF - PRINT CHS CPT CODE REPORT-BY VENDOR/DETAILED ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
D BRPT^ACHSFU
S (C,ACHSCHBS,ACHSCHBT,ACHSDOCS,ACHSCHAS,ACHSCHAT,ACHSDOCT,ACHS43T,ACHS57T,ACHS64T)=0
S (ACHS43,ACHS57,ACHS64,ACHSV43,ACHSV57,ACHSV64)=0
S (ACHSDOC,ACHSFLG,ACHSPAGE,ACHSVDCT,ACHSVCBT,ACHSVCAT)=0
S (ACHS43S,ACHS57S,ACHS64S)=0
S (ACHSDOCA,ACHSVNDR)=""
P1 ;EP
S ACHSVNDR=$O(^TMP("ACHSCPT",$J,ACHSVNDR))
G:ACHSVNDR="" TOTL
I ACHSVNDR=0 S ACHSPAGE=0 G NODATA1^ACHSCPTI
I $D(^TMP("ACHSCPT",$J,ACHSVNDR,0)) S ACHSPAGE=0 G NODATA^ACHSCPTI
S ACHSCODE=""
P2 ;
S ACHSCODE=$O(^TMP("ACHSCPT",$J,ACHSVNDR,ACHSCODE))
G:ACHSCODE="" VNDRTOT
S ACHSDOC=""
D HEADER^ACHSCPTI
P3 ;
S ACHSDOC=$O(^TMP("ACHSCPT",$J,ACHSVNDR,ACHSCODE,ACHSDOC))
G:ACHSDOC="" SUBTOTL
S ACHSDEN=""
P4 ;
S ACHSDEN=$O(^TMP("ACHSCPT",$J,ACHSVNDR,ACHSCODE,ACHSDOC,ACHSDEN))
G:ACHSDEN="" P3
GETADD ;Vendor address
S ACHSVEN=$P($G(^TMP("ACHSCPT",$J,ACHSVNDR,ACHSCODE,ACHSDOC,ACHSDEN)),U,10)
S 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(Z="":Z,1:$P($G(^DIC(5,ACHSVST,0)),U)),ACHSZIP=$S(Z="":Z,1:$P(Z,U,4))
D HEADER1^ACHSCPTI:ACHSFLG=0
S X=$G(^TMP("ACHSCPT",$J,ACHSVNDR,ACHSCODE,ACHSDOC,ACHSDEN))
GETSERV ;
S ACHSSER=$P(X,U,1),ACHSSERV=$S(ACHSSER=1:"HOSP",ACHSSER=2:"DENT",ACHSSER=3:"OUTP",1:"UNKN")
I ACHSSER=1 S ACHS43S=ACHS43S+1
I ACHSSER=2 S ACHS57S=ACHS57S+1
I ACHSSER=3 S ACHS64S=ACHS64S+1
S ACHSFROM=$E($P(X,U,2),4,5)_"/"_$E($P(X,U,2),6,7)_"/"_$E($P(X,U,2),2,3)
S ACHSTO=$E($P(X,U,3),4,5)_"/"_$E($P(X,U,3),6,7)_"/"_$E($P(X,U,3),2,3)
S ACHSWLU=$P(X,U,4),ACHSCHB=$P(X,U,5),ACHSCHA=$P(X,U,6)
S ACHSMSG=$P(X,U,7),ACHS2TH=$P(X,U,8),ACHSSURF=$P(X,U,9)
PRINT ;Prints data totals
W !,ACHSDOC,?12,ACHSSERV,?17,ACHSFROM_"-"_ACHSTO,?35,$J(ACHSWLU,2),?41,$J(ACHSMSG,2),?45,$J(ACHS2TH,2),?51,$J(ACHSSURF,2)
S X=ACHSCHB,X2=2
D COMMA^%DTC
W ?54,X
S X=ACHSCHA,X2=2
D COMMA^%DTC
W ?67,X
S ACHSCHBS=ACHSCHBS+ACHSCHB,ACHSCHAS=ACHSCHAS+ACHSCHA
S ACHSDOCS=ACHSDOCS+1,ACHSFLG=1
I IOST["P-",$Y>56 S ACHSFLG=0 D HEADER^ACHSCPTI,HEADER1^ACHSCPTI
I IOST["C-",'$D(IO("S")),$Y>24 K DIR S DIR(0)="E" D ^DIR G END:Y=0 S ACHSFLG=0
G P4
;
SUBTOTL ;
W !!,$$REPEAT^XLFSTR("-",80),!,"SUBTOTAL",?25,$J(ACHSDOCS,4)
S X=ACHSCHBS,X2="2$"
D COMMA^%DTC
W ?54,X
S X=ACHSCHAS,X2="2$"
D COMMA^%DTC
W ?67,X
I ACHSCHBS>0,ACHSCHAS>0 S X=(ACHSCHAS/ACHSCHBS)*100 W !!,"PERCENTAGE OF CHGS ALLOWED TO CHGS BILLED" W ?66,$E(X,1,5)_"%"
W !!?3,"** HOSP - "_ACHS43S_" **",?32,"** DENT - "_ACHS57S_" **",?62,"** OUTP - "_ACHS64S_" **"
S ACHSCHBT=ACHSCHBT+ACHSCHBS,ACHSCHAT=ACHSCHAT+ACHSCHAS,ACHSDOCT=ACHSDOCT+ACHSDOCS
S ACHS43T=ACHS43T+ACHS43S,ACHS57T=ACHS57T+ACHS57S,ACHS64T=ACHS64T+ACHS64S
S ACHSVDCT=ACHSVDCT+ACHSDOCS,ACHSVCBT=ACHSVCBT+ACHSCHBS,ACHSVCAT=ACHSVCAT+ACHSCHAS
S ACHSV43=ACHSV43+ACHS43S,ACHSV57=ACHSV57+ACHS57S,ACHSV64=ACHSV64+ACHS64S
K DIR
I IOST["C-",'$D(IO("S")) S DIR(0)="E" W !! D ^DIR G END:Y=0
S (C,ACHSCHBS,ACHSCHAS,ACHSDOCS,ACHSFLG,ACHS43S,ACHS57S,ACHS64S)=0
G P2
;
VNDRTOT ;
W !!,$$REPEAT^XLFSTR("=",80),!,"VENDOR TOTALS",?25,$J(ACHSVDCT,4)
S X=ACHSVCBT,X2="2$"
D COMMA^%DTC
W ?56,X
S X=ACHSVCAT,X2="2$"
D COMMA^%DTC
W ?68,X
I ACHSVCBT>0,ACHSVCAT>0 S X=(ACHSVCAT/ACHSVCBT)*100 W !!,"PERCENTAGE OF CHGS ALLOWED TO CHGS BILLED" W ?66,$E(X,1,5)_"%"
W !!?3,"** HOSP - "_ACHSV43_" **",?32,"** DENT - "_ACHSV57_" **",?62,"** OUTP - "_ACHSV64_" **"
K DIR
I IOST["C-",'$D(IO("S")) S DIR(0)="E" W !! D ^DIR G END:Y=0
S (ACHSVDCT,ACHSVCBT,ACHSVCAT,ACHSPAGE,ACHSV43,ACHSV57,ACHSV64)=0
G P1
;
TOTL ;
W !!!!,$$REPEAT^XLFSTR("=",80),!!,"TOTAL",?25,$J(ACHSDOCT,4)
S X=ACHSCHBT,X2="2$"
D COMMA^%DTC
W ?54,X
S X=ACHSCHAT,X2="2$"
D COMMA^%DTC
W ?67,X
I ACHSCHBT>0,ACHSCHAT>0 S X=(ACHSCHAT/ACHSCHBT)*100 W !!,"PERCENTAGE OF CHGS ALLOWED TO CHGS BILLED" W ?66,$E(X,1,5)_"%"
W !!?3,"** HOSP - "_ACHS43T_" **",?32,"** DENT - "_ACHS57T_" **",?62,"** OUTP - "_ACHS64T_" **"
I IOST["C-",'$D(IO("S")) K DIR S DIR(0)="E" W !! D ^DIR G END:Y=0
Q
;
END ;
K ACHSPAGE,C,ACHSCHBS,ACHSCHBT,ACHSDOCS,ACHSCHBT,ACHSDOCT
K ACHS2TH,ACHS43S,ACHS43T,ACHS57S,ACHS57T,ACHS64S,ACHS64T
K ACHSCHA,ACHSCHAS,ACHSCHB,ACHSCHBS,ACHSV64,ACHSVA
K ACHSDOC,ACHSCODE,ACHSDEN,ACHSDOCA
K ACHSIOQ,ACHSCHAT,ACHSVADD,ACHSVCIT,ACHSVEN,ACHSVNDR
K ACHSVST,ACHSZIP,I,Z,ACHSFLG,X,X2,Y,^TMP("ACHSCPT",$J),ACHSFROM
K ACHSMSG,ACHSSER,ACHSSERV,ACHSSURF,ACHSTO,ACHSV43,ACHSV57
K ACHSVCAT,ACHSVCBT,ACHSVDCT,ACHSWLU,DIR
G END^ACHSCPTI ;To close device, quit
;
ACHSCPTH ; IHS/ITSC/PMF - PRINT CHS CPT CODE REPORT-BY VENDOR/DETAILED ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 DO BRPT^ACHSFU
+4 SET (C,ACHSCHBS,ACHSCHBT,ACHSDOCS,ACHSCHAS,ACHSCHAT,ACHSDOCT,ACHS43T,ACHS57T,ACHS64T)=0
+5 SET (ACHS43,ACHS57,ACHS64,ACHSV43,ACHSV57,ACHSV64)=0
+6 SET (ACHSDOC,ACHSFLG,ACHSPAGE,ACHSVDCT,ACHSVCBT,ACHSVCAT)=0
+7 SET (ACHS43S,ACHS57S,ACHS64S)=0
+8 SET (ACHSDOCA,ACHSVNDR)=""
P1 ;EP
+1 SET ACHSVNDR=$ORDER(^TMP("ACHSCPT",$JOB,ACHSVNDR))
+2 IF ACHSVNDR=""
GOTO TOTL
+3 IF ACHSVNDR=0
SET ACHSPAGE=0
GOTO NODATA1^ACHSCPTI
+4 IF $DATA(^TMP("ACHSCPT",$JOB,ACHSVNDR,0))
SET ACHSPAGE=0
GOTO NODATA^ACHSCPTI
+5 SET ACHSCODE=""
P2 ;
+1 SET ACHSCODE=$ORDER(^TMP("ACHSCPT",$JOB,ACHSVNDR,ACHSCODE))
+2 IF ACHSCODE=""
GOTO VNDRTOT
+3 SET ACHSDOC=""
+4 DO HEADER^ACHSCPTI
P3 ;
+1 SET ACHSDOC=$ORDER(^TMP("ACHSCPT",$JOB,ACHSVNDR,ACHSCODE,ACHSDOC))
+2 IF ACHSDOC=""
GOTO SUBTOTL
+3 SET ACHSDEN=""
P4 ;
+1 SET ACHSDEN=$ORDER(^TMP("ACHSCPT",$JOB,ACHSVNDR,ACHSCODE,ACHSDOC,ACHSDEN))
+2 IF ACHSDEN=""
GOTO P3
GETADD ;Vendor address
+1 SET ACHSVEN=$PIECE($GET(^TMP("ACHSCPT",$JOB,ACHSVNDR,ACHSCODE,ACHSDOC,ACHSDEN)),U,10)
+2 SET Z=$GET(^AUTTVNDR(ACHSVEN,13))
+3 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(Z="":Z,1:$PIECE($GET(^DIC(5,ACHSVST,0)),U))
SET ACHSZIP=$SELECT(Z="":Z,1:$PIECE(Z,U,4))
+4 IF ACHSFLG=0
DO HEADER1^ACHSCPTI
+5 SET X=$GET(^TMP("ACHSCPT",$JOB,ACHSVNDR,ACHSCODE,ACHSDOC,ACHSDEN))
GETSERV ;
+1 SET ACHSSER=$PIECE(X,U,1)
SET ACHSSERV=$SELECT(ACHSSER=1:"HOSP",ACHSSER=2:"DENT",ACHSSER=3:"OUTP",1:"UNKN")
+2 IF ACHSSER=1
SET ACHS43S=ACHS43S+1
+3 IF ACHSSER=2
SET ACHS57S=ACHS57S+1
+4 IF ACHSSER=3
SET ACHS64S=ACHS64S+1
+5 SET ACHSFROM=$EXTRACT($PIECE(X,U,2),4,5)_"/"_$EXTRACT($PIECE(X,U,2),6,7)_"/"_$EXTRACT($PIECE(X,U,2),2,3)
+6 SET ACHSTO=$EXTRACT($PIECE(X,U,3),4,5)_"/"_$EXTRACT($PIECE(X,U,3),6,7)_"/"_$EXTRACT($PIECE(X,U,3),2,3)
+7 SET ACHSWLU=$PIECE(X,U,4)
SET ACHSCHB=$PIECE(X,U,5)
SET ACHSCHA=$PIECE(X,U,6)
+8 SET ACHSMSG=$PIECE(X,U,7)
SET ACHS2TH=$PIECE(X,U,8)
SET ACHSSURF=$PIECE(X,U,9)
PRINT ;Prints data totals
+1 WRITE !,ACHSDOC,?12,ACHSSERV,?17,ACHSFROM_"-"_ACHSTO,?35,$JUSTIFY(ACHSWLU,2),?41,$JUSTIFY(ACHSMSG,2),?45,$JUSTIFY(ACHS2TH,2),?51,$JUSTIFY(ACHSSURF,2)
+2 SET X=ACHSCHB
SET X2=2
+3 DO COMMA^%DTC
+4 WRITE ?54,X
+5 SET X=ACHSCHA
SET X2=2
+6 DO COMMA^%DTC
+7 WRITE ?67,X
+8 SET ACHSCHBS=ACHSCHBS+ACHSCHB
SET ACHSCHAS=ACHSCHAS+ACHSCHA
+9 SET ACHSDOCS=ACHSDOCS+1
SET ACHSFLG=1
+10 IF IOST["P-"
IF $Y>56
SET ACHSFLG=0
DO HEADER^ACHSCPTI
DO HEADER1^ACHSCPTI
+11 IF IOST["C-"
IF '$DATA(IO("S"))
IF $Y>24
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF Y=0
GOTO END
SET ACHSFLG=0
+12 GOTO P4
+13 ;
SUBTOTL ;
+1 WRITE !!,$$REPEAT^XLFSTR("-",80),!,"SUBTOTAL",?25,$JUSTIFY(ACHSDOCS,4)
+2 SET X=ACHSCHBS
SET X2="2$"
+3 DO COMMA^%DTC
+4 WRITE ?54,X
+5 SET X=ACHSCHAS
SET X2="2$"
+6 DO COMMA^%DTC
+7 WRITE ?67,X
+8 IF ACHSCHBS>0
IF ACHSCHAS>0
SET X=(ACHSCHAS/ACHSCHBS)*100
WRITE !!,"PERCENTAGE OF CHGS ALLOWED TO CHGS BILLED"
WRITE ?66,$EXTRACT(X,1,5)_"%"
+9 WRITE !!?3,"** HOSP - "_ACHS43S_" **",?32,"** DENT - "_ACHS57S_" **",?62,"** OUTP - "_ACHS64S_" **"
+10 SET ACHSCHBT=ACHSCHBT+ACHSCHBS
SET ACHSCHAT=ACHSCHAT+ACHSCHAS
SET ACHSDOCT=ACHSDOCT+ACHSDOCS
+11 SET ACHS43T=ACHS43T+ACHS43S
SET ACHS57T=ACHS57T+ACHS57S
SET ACHS64T=ACHS64T+ACHS64S
+12 SET ACHSVDCT=ACHSVDCT+ACHSDOCS
SET ACHSVCBT=ACHSVCBT+ACHSCHBS
SET ACHSVCAT=ACHSVCAT+ACHSCHAS
+13 SET ACHSV43=ACHSV43+ACHS43S
SET ACHSV57=ACHSV57+ACHS57S
SET ACHSV64=ACHSV64+ACHS64S
+14 KILL DIR
+15 IF IOST["C-"
IF '$DATA(IO("S"))
SET DIR(0)="E"
WRITE !!
DO ^DIR
IF Y=0
GOTO END
+16 SET (C,ACHSCHBS,ACHSCHAS,ACHSDOCS,ACHSFLG,ACHS43S,ACHS57S,ACHS64S)=0
+17 GOTO P2
+18 ;
VNDRTOT ;
+1 WRITE !!,$$REPEAT^XLFSTR("=",80),!,"VENDOR TOTALS",?25,$JUSTIFY(ACHSVDCT,4)
+2 SET X=ACHSVCBT
SET X2="2$"
+3 DO COMMA^%DTC
+4 WRITE ?56,X
+5 SET X=ACHSVCAT
SET X2="2$"
+6 DO COMMA^%DTC
+7 WRITE ?68,X
+8 IF ACHSVCBT>0
IF ACHSVCAT>0
SET X=(ACHSVCAT/ACHSVCBT)*100
WRITE !!,"PERCENTAGE OF CHGS ALLOWED TO CHGS BILLED"
WRITE ?66,$EXTRACT(X,1,5)_"%"
+9 WRITE !!?3,"** HOSP - "_ACHSV43_" **",?32,"** DENT - "_ACHSV57_" **",?62,"** OUTP - "_ACHSV64_" **"
+10 KILL DIR
+11 IF IOST["C-"
IF '$DATA(IO("S"))
SET DIR(0)="E"
WRITE !!
DO ^DIR
IF Y=0
GOTO END
+12 SET (ACHSVDCT,ACHSVCBT,ACHSVCAT,ACHSPAGE,ACHSV43,ACHSV57,ACHSV64)=0
+13 GOTO P1
+14 ;
TOTL ;
+1 WRITE !!!!,$$REPEAT^XLFSTR("=",80),!!,"TOTAL",?25,$JUSTIFY(ACHSDOCT,4)
+2 SET X=ACHSCHBT
SET X2="2$"
+3 DO COMMA^%DTC
+4 WRITE ?54,X
+5 SET X=ACHSCHAT
SET X2="2$"
+6 DO COMMA^%DTC
+7 WRITE ?67,X
+8 IF ACHSCHBT>0
IF ACHSCHAT>0
SET X=(ACHSCHAT/ACHSCHBT)*100
WRITE !!,"PERCENTAGE OF CHGS ALLOWED TO CHGS BILLED"
WRITE ?66,$EXTRACT(X,1,5)_"%"
+9 WRITE !!?3,"** HOSP - "_ACHS43T_" **",?32,"** DENT - "_ACHS57T_" **",?62,"** OUTP - "_ACHS64T_" **"
+10 IF IOST["C-"
IF '$DATA(IO("S"))
KILL DIR
SET DIR(0)="E"
WRITE !!
DO ^DIR
IF Y=0
GOTO END
+11 QUIT
+12 ;
END ;
+1 KILL ACHSPAGE,C,ACHSCHBS,ACHSCHBT,ACHSDOCS,ACHSCHBT,ACHSDOCT
+2 KILL ACHS2TH,ACHS43S,ACHS43T,ACHS57S,ACHS57T,ACHS64S,ACHS64T
+3 KILL ACHSCHA,ACHSCHAS,ACHSCHB,ACHSCHBS,ACHSV64,ACHSVA
+4 KILL ACHSDOC,ACHSCODE,ACHSDEN,ACHSDOCA
+5 KILL ACHSIOQ,ACHSCHAT,ACHSVADD,ACHSVCIT,ACHSVEN,ACHSVNDR
+6 KILL ACHSVST,ACHSZIP,I,Z,ACHSFLG,X,X2,Y,^TMP("ACHSCPT",$JOB),ACHSFROM
+7 KILL ACHSMSG,ACHSSER,ACHSSERV,ACHSSURF,ACHSTO,ACHSV43,ACHSV57
+8 KILL ACHSVCAT,ACHSVCBT,ACHSVDCT,ACHSWLU,DIR
+9 ;To close device, quit
GOTO END^ACHSCPTI
+10 ;
