ACHSDNL5 ; IHS/ITSC/TPF/PMF - DENIAL LTR/FS (FS2) (6/6) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**19**;JUN 11, 2001
Q:$G(ACHSQUIT)
W $S(ACHSUMET=1:" VENDOR(S)",1:" VENDOR(S) suggested"),?48,"CHARGES" S ACHSTOT("$")=0
S ACHSPPRO=^ACHSDEN(DUZ(2),"D",ACHSA,100) G VEND0:$P(ACHSPPRO,U)'="Y" S (ACHSVPTR,A)=$P(ACHSPPRO,U,2) G VEND0:A']"",VEND0:'$D(^AUTTVNDR(A,0)) W !,$P(^(0),U) ;S ACHSVPTR=A ***TPF SET PTR ALONG WITH A SINCE NO CHANGE LATER ON LINE
S X=$P(ACHSPPRO,U,9) I X]"" S ACHSTOT("$")=ACHSTOT("$")+X D COMMA^%DTC W ?40,$J(X,6),"(ACTUAL)" G T2
S X=$P(ACHSPPRO,U,8) I X]"" S ACHSTOT("$")=ACHSTOT("$")+X D COMMA^%DTC W ?40,$J(X,6),"(EST.)"
;
T2 D ADDR
G V1
;
VEND0 W !,$P(ACHSPPRO,U,3) S X=$P(ACHSPPRO,U,9) I X]"" S ACHSTOT("$")=ACHSTOT("$")+X D COMMA^%DTC W ?40,$J(X,6),"(ACTUAL)" G T4
S X=$P(ACHSPPRO,U,8) I X]"" S ACHSTOT("$")=ACHSTOT("$")+X D COMMA^%DTC W ?40,$J(X,6),"(EST.)"
;
T4 S X=$P(ACHSPPRO,U,4)_U_$P(ACHSPPRO,U,5)_U_$P(ACHSPPRO,U,6)_U_$P(ACHSPPRO,U,7) D SUBADDR
;
V1 ;
S DA(1)=0 G VEND2:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,200,0)),VEND2:+$P(^(0),U,3)=0
;
VEND1 S DA(1)=$O(^ACHSDEN(DUZ(2),"D",ACHSA,200,DA(1))) G VEND2:+DA(1)=0 S A(1)=^(DA(1),0),A(2)=+A(1) G VEND1:A(2)'>0,VEND1:'$D(^AUTTVNDR(A(2),0)) W !,$P(^(0),U),?40
S X=$P(A(1),U,3) I X]"" S ACHSTOT("$")=ACHSTOT("$")+X D COMMA^%DTC W $J(X,6),"(ACTUAL)" G TYPE1
S X=$P(A(1),U,2) I X]"" S ACHSTOT("$")=ACHSTOT("$")+X D COMMA^%DTC W $J(X,6),"(EST.)"
;
TYPE1 S ACHSVPTR=A(2) D ADDR
G VEND1
;
VEND2 S DA(2)=0 G TOTAL:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,210,0)),TOTAL:+$P(^(0),U,4)=0
;
V2 S DA(2)=$O(^ACHSDEN(DUZ(2),"D",ACHSA,210,DA(2))) G TOTAL:+DA(2)=0 S A(1)=^(DA(2),0) W !,$P(A(1),U)
S X=$P(A(1),U,7) I X]"" S ACHSTOT("$")=ACHSTOT("$")+X D COMMA^%DTC W ?40,$J(X,6),"(ACTUAL)" G T5
S X=$P(A(1),U,6) I X]"" S ACHSTOT("$")=ACHSTOT("$")+X D COMMA^%DTC W ?40,$J(X,6),"(EST.)"
;
T5 S X=$P(A(1),U,2,5) D SUBADDR
G V2
;
TOTAL ;
;3/25/01 PMF somehow we get here and the dashes are not
;defined. This call to get them set is temporary. They
;should be set when initializing
D LINES^ACHSFU
Q:$G(ACHSQUIT)
W ?30,$E(ACHS("-"),1,30),! S X=ACHSTOT("$") D COMMA^%DTC W ?30,"TOTAL:",?40,$J(X,6)
G END:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,800,0)),END:+$P(^(0),U,4)=0
S ACHSTOT1("$")=0 W !,ACHS("-"),!," OTHER RESOURCES",?37,"AMOUNT PAID (IF ANY)"
;
F A=0:0 S A=$O(^ACHSDEN(DUZ(2),"D",ACHSA,800,A)) Q:'A D
. S OTHRES=$G(^ACHSDEN(DUZ(2),"D",ACHSA,800,A,0)) Q:OTHRES=""
. S INSR=$P(OTHRES,U,1) Q:INSR=""
. S INSR=$G(^AUTNINS(INSR,0)) Q:INSR=""
. W !,$P(INSR,U)
. S X=+$P(OTHRES,U,2),ACHSTOT1("$")=ACHSTOT1("$")+X
. D COMMA^%DTC W ?40,$J(X,6)
. Q
K X,INSR,OTHRES
;
S X=ACHSTOT1("$") D COMMA^%DTC W !?30,$E(ACHS("-"),1,30),!?30,"TOTAL: ",?40,$J(X,6)
S X=(ACHSTOT("$")-ACHSTOT1("$")) D COMMA^%DTC W !,ACHS("-"),!?28,"BALANCE:",?40,$J(X,6),!
;
END ;EP.
W ! D CPI^ACHS,RTRN^ACHS W @IOF
K A,ACHSDOS,ACHSISDT,ACHSNAME,ACHSNAMP,ACHSPDR,ACHSPPRO,ACHSRQDT,ACHSST,ACHSTOT,ACHSTOT1,ACHSVPTR,DTOUT,DUOUT
Q
ADDR ;EP.
Q:$G(ACHSVPTR)="" ;***TPF BLOODY WELL QUIT IF WE DON'T HAVE A VALID PTR
Q:'$D(^AUTTVNDR(ACHSVPTR,13)) S A=^(13) S X=$P(A,U)_U_$P(A,U,2)_U_$P(A,U,3)_U_$P(A,U,4)
SUBADDR ;EP.
S:'$D(DIWL) DIWL=5 ;ACHS*3.1*19
W !?DIWL-1,$P(X,U),!?DIWL-1,$P(X,U,2) S ACHSST=$P(X,U,3) I ACHSST]"",$D(^DIC(5,ACHSST,0)) W " ",$P(^(0),U,2)
W " ",$P(X,U,4),!
Q
ACHSDNL5 ; IHS/ITSC/TPF/PMF - DENIAL LTR/FS (FS2) (6/6) ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**19**;JUN 11, 2001
+2 IF $GET(ACHSQUIT)
QUIT
+3 WRITE $SELECT(ACHSUMET=1:" VENDOR(S)",1:" VENDOR(S) suggested"),?48,"CHARGES"
SET ACHSTOT("$")=0
+4 ;S ACHSVPTR=A ***TPF SET PTR ALONG WITH A SINCE NO CHANGE LATER ON LINE
SET ACHSPPRO=^ACHSDEN(DUZ(2),"D",ACHSA,100)
IF $PIECE(ACHSPPRO,U)'="Y"
GOTO VEND0
SET (ACHSVPTR,A)=$PIECE(ACHSPPRO,U,2)
IF A']""
GOTO VEND0
IF '$DATA(^AUTTVNDR(A,0))
GOTO VEND0
WRITE !,$PIECE(^(0),U)
+5 SET X=$PIECE(ACHSPPRO,U,9)
IF X]""
SET ACHSTOT("$")=ACHSTOT("$")+X
DO COMMA^%DTC
WRITE ?40,$JUSTIFY(X,6),"(ACTUAL)"
GOTO T2
+6 SET X=$PIECE(ACHSPPRO,U,8)
IF X]""
SET ACHSTOT("$")=ACHSTOT("$")+X
DO COMMA^%DTC
WRITE ?40,$JUSTIFY(X,6),"(EST.)"
+7 ;
T2 DO ADDR
+1 GOTO V1
+2 ;
VEND0 WRITE !,$PIECE(ACHSPPRO,U,3)
SET X=$PIECE(ACHSPPRO,U,9)
IF X]""
SET ACHSTOT("$")=ACHSTOT("$")+X
DO COMMA^%DTC
WRITE ?40,$JUSTIFY(X,6),"(ACTUAL)"
GOTO T4
+1 SET X=$PIECE(ACHSPPRO,U,8)
IF X]""
SET ACHSTOT("$")=ACHSTOT("$")+X
DO COMMA^%DTC
WRITE ?40,$JUSTIFY(X,6),"(EST.)"
+2 ;
T4 SET X=$PIECE(ACHSPPRO,U,4)_U_$PIECE(ACHSPPRO,U,5)_U_$PIECE(ACHSPPRO,U,6)_U_$PIECE(ACHSPPRO,U,7)
DO SUBADDR
+1 ;
V1 ;
+1 SET DA(1)=0
IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,200,0))
GOTO VEND2
IF +$PIECE(^(0),U,3)=0
GOTO VEND2
+2 ;
VEND1 SET DA(1)=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,200,DA(1)))
IF +DA(1)=0
GOTO VEND2
SET A(1)=^(DA(1),0)
SET A(2)=+A(1)
IF A(2)'>0
GOTO VEND1
IF '$DATA(^AUTTVNDR(A(2),0))
GOTO VEND1
WRITE !,$PIECE(^(0),U),?40
+1 SET X=$PIECE(A(1),U,3)
IF X]""
SET ACHSTOT("$")=ACHSTOT("$")+X
DO COMMA^%DTC
WRITE $JUSTIFY(X,6),"(ACTUAL)"
GOTO TYPE1
+2 SET X=$PIECE(A(1),U,2)
IF X]""
SET ACHSTOT("$")=ACHSTOT("$")+X
DO COMMA^%DTC
WRITE $JUSTIFY(X,6),"(EST.)"
+3 ;
TYPE1 SET ACHSVPTR=A(2)
DO ADDR
+1 GOTO VEND1
+2 ;
VEND2 SET DA(2)=0
IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,210,0))
GOTO TOTAL
IF +$PIECE(^(0),U,4)=0
GOTO TOTAL
+1 ;
V2 SET DA(2)=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,210,DA(2)))
IF +DA(2)=0
GOTO TOTAL
SET A(1)=^(DA(2),0)
WRITE !,$PIECE(A(1),U)
+1 SET X=$PIECE(A(1),U,7)
IF X]""
SET ACHSTOT("$")=ACHSTOT("$")+X
DO COMMA^%DTC
WRITE ?40,$JUSTIFY(X,6),"(ACTUAL)"
GOTO T5
+2 SET X=$PIECE(A(1),U,6)
IF X]""
SET ACHSTOT("$")=ACHSTOT("$")+X
DO COMMA^%DTC
WRITE ?40,$JUSTIFY(X,6),"(EST.)"
+3 ;
T5 SET X=$PIECE(A(1),U,2,5)
DO SUBADDR
+1 GOTO V2
+2 ;
TOTAL ;
+1 ;3/25/01 PMF somehow we get here and the dashes are not
+2 ;defined. This call to get them set is temporary. They
+3 ;should be set when initializing
+4 DO LINES^ACHSFU
+5 IF $GET(ACHSQUIT)
QUIT
+6 WRITE ?30,$EXTRACT(ACHS("-"),1,30),!
SET X=ACHSTOT("$")
DO COMMA^%DTC
WRITE ?30,"TOTAL:",?40,$JUSTIFY(X,6)
+7 IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,800,0))
GOTO END
IF +$PIECE(^(0),U,4)=0
GOTO END
+8 SET ACHSTOT1("$")=0
WRITE !,ACHS("-"),!," OTHER RESOURCES",?37,"AMOUNT PAID (IF ANY)"
+9 ;
+10 FOR A=0:0
SET A=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,800,A))
IF 'A
QUIT
Begin DoDot:1
+11 SET OTHRES=$GET(^ACHSDEN(DUZ(2),"D",ACHSA,800,A,0))
IF OTHRES=""
QUIT
+12 SET INSR=$PIECE(OTHRES,U,1)
IF INSR=""
QUIT
+13 SET INSR=$GET(^AUTNINS(INSR,0))
IF INSR=""
QUIT
+14 WRITE !,$PIECE(INSR,U)
+15 SET X=+$PIECE(OTHRES,U,2)
SET ACHSTOT1("$")=ACHSTOT1("$")+X
+16 DO COMMA^%DTC
WRITE ?40,$JUSTIFY(X,6)
+17 QUIT
End DoDot:1
+18 KILL X,INSR,OTHRES
+19 ;
+20 SET X=ACHSTOT1("$")
DO COMMA^%DTC
WRITE !?30,$EXTRACT(ACHS("-"),1,30),!?30,"TOTAL: ",?40,$JUSTIFY(X,6)
+21 SET X=(ACHSTOT("$")-ACHSTOT1("$"))
DO COMMA^%DTC
WRITE !,ACHS("-"),!?28,"BALANCE:",?40,$JUSTIFY(X,6),!
+22 ;
END ;EP.
+1 WRITE !
DO CPI^ACHS
DO RTRN^ACHS
WRITE @IOF
+2 KILL A,ACHSDOS,ACHSISDT,ACHSNAME,ACHSNAMP,ACHSPDR,ACHSPPRO,ACHSRQDT,ACHSST,ACHSTOT,ACHSTOT1,ACHSVPTR,DTOUT,DUOUT
+3 QUIT
ADDR ;EP.
+1 ;***TPF BLOODY WELL QUIT IF WE DON'T HAVE A VALID PTR
IF $GET(ACHSVPTR)=""
QUIT
+2 IF '$DATA(^AUTTVNDR(ACHSVPTR,13))
QUIT
SET A=^(13)
SET X=$PIECE(A,U)_U_$PIECE(A,U,2)_U_$PIECE(A,U,3)_U_$PIECE(A,U,4)
SUBADDR ;EP.
+1 ;ACHS*3.1*19
IF '$DATA(DIWL)
SET DIWL=5
+2 WRITE !?DIWL-1,$PIECE(X,U),!?DIWL-1,$PIECE(X,U,2)
SET ACHSST=$PIECE(X,U,3)
IF ACHSST]""
IF $DATA(^DIC(5,ACHSST,0))
WRITE " ",$PIECE(^(0),U,2)
+3 WRITE " ",$PIECE(X,U,4),!
+4 QUIT
