- 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
