ACHSPAZ.m

ACHSPAZ ; IHS/ITSC/PMF - DOCUMENT PAYMENT - ENTER SVDT,WKLD,FULP,3RDP,VAMT ;    [ 02/02/2005  11:12 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**12,19**;JUN 11, 2001

 ;

 S (ACHSADDT,ACHSDIDT,ACHSDITY,ACHSSVDT,ACHSWKLD,ACHSFULP,ACHS3RDP,ACHS3RDS,ACHSVAMT,ACHSCTL,ACHSCHK,ACHSREM,ACHSSV,ACHSOB,ACHSPACC)=""

A1 ;

 W !!,"Date Of Service: "

 I ACHSSVDT W $$FMTE^XLFDT(ACHSSVDT),"// "

 D READ^ACHSFU

 I $G(ACHSQUIT) D END Q

 I Y?1"?".E W !,"  Enter The Date The Patient First Received Treatment" G A1

 I Y="" G A3:ACHSSVDT W !!,"Must enter Date of Service" G A1

 S X=Y,%DT="EXQP"

 D ^%DT

 I Y<1 S ACHSSVDT="" G A1

 I Y<ACHSODT S ACHSSVDT=Y W *7,!,"SERVICE date is before ORDER date.",! G A2

 S ACHSSVDT=Y

 G A3

 ;

A2 ;

 S Y=$$DIR^XBDIR("Y","Are You Sure This Is Correct ","NO","","","",2)

 I $D(DTOUT) D END Q

 G A1:$D(DUOUT)!('Y)

A3 ;

 S Y=$$DIR^XBDIR("N^1:9999:0","Workload Units",$G(ACHSWKLD),""," Enter # of Visits, Days &/or Tests","",2)

 I $D(DTOUT) D END Q

 G A1:$D(DUOUT)

 S ACHSWKLD=Y

 ;

A3A ; Set O/P visit to Hospital node

 ;

 ;GET OBJECT CLASSIFICATION PTR THEN GET CODE

 ;254D = PHYS OUTP NON-IHS

 I $$DOC^ACHS(0,7) I $P(^ACHS(3,DUZ(2),1,$$DOC^ACHS(0,7),0),U)'="254D" G A4

 ;GET PROVIDER (VENDOR) PTR THEN GET PROVIDER TYPE

 I $$DOC^ACHS(0,8) I +$P(^AUTTVNDR($$DOC^ACHS(0,8),11),U,3)'="" I $D(^AUTTVTYP(+$P($G(^AUTTVNDR($$DOC^ACHS(0,8),11)),U,3),0)) S %=$P(^(0),U) I (%="05")!(%="06") G A4

 D DIR("9002080.02,9.1^O",$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA,0)),U,16))

 I $D(DTOUT) D END Q

 G A3:$D(DUOUT)

 S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA,0),U,16)=Y  ;HOSPITAL OUTPATIENT

A4 ;

 ;

 D ^ACHSPAA                   ;DOCUMENT PAYMENT ENTER/EDIT AMOUNT

 I $D(DTOUT) D END Q          ;RETURNED VARS ACHSIPA,ACHSVAMT,ACHSPAMT   

 G A3:$D(DUOUT)

 ;

 I +ACHSVAMT=0 S ACHSFULP="P" G A6

A5 ;

 S ACHSFULP=$$DIR^XBDIR("9002080.02,4","Payment Status",$G(ACHSFULP),"","","",2)

 G A4:$D(DUOUT),END:$D(DTOUT)

 I '$L(ACHSFULP) W "  Required" G A5

A6 ;

 I ACHSFULP="F" S (ACHS3RDP,ACHS3RDS)="" G A7A

A7 ;

 W !!,"Enter Amount Paid by all Third Parties: "

 I ACHS3RDP S X=ACHS3RDP D FMT^ACHS W "//"

 D READ^ACHSFU

 I $D(DTOUT) D END Q

 G A5:$D(DUOUT)

 I Y?1"?".E W !," Enter difference between total bill and amount paid by IHS" G A6

 I Y="" G SRC:ACHS3RDP

 S ACHS3RDP=$J(Y,0,2)

 W "   ("

 S X=ACHS3RDP

 D FMT^ACHS

 W ")"

SRC ; 3P source

 S ACHS3RDS=$P($G(^AUTNINS(+$G(ACHS3RDS),0)),U)  ;'NAME' FROM 'INSURER'

 D DIR("9002080.02,12^O",$G(ACHS3RDS))

 I $D(DTOUT) D END Q

 G A5:$D(DUOUT)

 S ACHS3RDS=$S(+Y>0:+Y,1:"")

 ;

A7A ; Pay indicator: Final/Interim

 S:'$D(ACHSF638) ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)

 I $$DOC^ACHS(0,17)="I" S ACHSPIND="F" G A7C

 D DIR("9002080.02,15",$$EXTSET^XBFUNC(9002080.02,15,$G(ACHSPIND)))

 G A5:$D(DUOUT),END:$D(DTOUT)

 I '$L(Y) W *7,"  Required" G A7A

 S ACHSPIND=Y

 ;

A7C ; EOBR pay date

 ;I ACHSF638="Y" S ACHSPDAT=DT G A8

 I $$PARM^ACHS(2,11)'="Y",ACHSF638="Y" S ACHSPDAT=DT G A8    ;ACHS*3.1*19 IHS/OIT.FCJ ADDED FOR TRIBAL SITES USING THE FI

 D DIR("9002080.02,13",$$FMTE^XLFDT($G(ACHSPDAT),1))

 I $D(DTOUT) D END Q

 G A5:$D(DUOUT)

 I '$L(Y) W *7,"  Required" G A7C

 S ACHSPDAT=Y

 G:$$DOC^ACHS(0,17)'="F" A8   ;DOCUMENT DESTINATION  F= FI

 ;

A7D ; EOBR Control Number

 ;G:ACHSF638="Y" A8

 I $$PARM^ACHS(2,11)'="Y",ACHSF638="Y" S ACHSPDAT=DT G A8    ;ACHS*3.1*19 IHS/OIT.FCJ ADDED FOR TRIBAL SITES USING THE FI

 D DIR("9002080.02,16",$G(ACHSCTL))

 I $D(DTOUT) D END Q

 G A5:$D(DUOUT)

 I '$L(Y) W *7,"  Required" G A7D

 S ACHSCTL=Y

 ;

A7E ; EOBR Check number

 D DIR("9002080.02,17",$G(ACHSCHK))

 I $D(DTOUT) D END Q

 G A5:$D(DUOUT)

 I '$L(Y) W *7,"  Required" G A7E

 S ACHSCHK=Y

 ;

A7F ; EOBR Remittance number

 D DIR("9002080.02,18",$G(ACHSREM))

 I $D(DTOUT) D END Q

 G A5:$D(DUOUT)

 I '$L(Y) W *7,"  Required" G A7F

 S ACHSREM=Y

 ;

A7G ; EOBR Services

 D DIR("9002080.02,19",$$EXTSET^XBFUNC(9002080.02,19,$G(ACHSSV)))

 I $D(DTOUT) D END Q

 G A5:$D(DUOUT)

 I '$L(Y) W *7,"  Required" G A7G

 S ACHSSV=Y

 ;

A7H ; EOBR Obligation type

 D DIR("9002080.02,20",$$EXTSET^XBFUNC(9002080.02,20,$G(ACHSOB)))

 I $D(DTOUT) D END Q

 G A5:$D(DUOUT)

 I '$L(Y) W *7,"  Required" G A7H

 S ACHSOB=Y

 ;

A8 ;

 ;ITSC/SET/JVK 1.25.05 ACHS*3.1*12 NXT 4 LINES PATIENT ACCT NO

 I ACHSF638="Y" D

 .S DIR(0)="9002080.01,26.01"

 .S DIR("A")="Patient Account #"

 .D ^DIR

 .S ACHSPACC=Y

 .K DIR

 .Q

 S ACHSPSQN=$G(^ACHSF(DUZ(2),"SEQN"))+1

 S ^ACHSF(DUZ(2),"SEQN")=ACHSPSQN

 S Y=$$DIR^XBDIR("Y","Are All Entries Correct","NO","","","",2)

 G END:$D(DTOUT),A3:$D(DUOUT),A1:'Y

 S ACHSSET=1

 W !!,"***  Document Paid  ***"

 I $P(^ACHSF(DUZ(2),0),U,8)="Y",$P(^(0),U,9)="Y" S ^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN)="" W !!,"***  Document added to Check-print list.  ***"

END ;

 K ACHSVAMT,X2,X3

 Q

 ;

DIR(ACHS,ACHS1) ; ( <DIR(0)> , <DIR("B")> )

 W !

 K DIR,DUOUT,DTOUT,DIRUT

 S DIR(0)=ACHS

 I $L($G(ACHS1)) S DIR("B")=ACHS1

 D ^DIR

 K DIR

 Q

 ;

ACHSPAZ   ; IHS/ITSC/PMF - DOCUMENT PAYMENT - ENTER SVDT,WKLD,FULP,3RDP,VAMT ;    [ 02/02/2005  11:12 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**12,19**;JUN 11, 2001

 +2       ;

 +3        SET (ACHSADDT,ACHSDIDT,ACHSDITY,ACHSSVDT,ACHSWKLD,ACHSFULP,ACHS3RDP,ACHS3RDS,ACHSVAMT,ACHSCTL,ACHSCHK,ACHSREM,ACHSSV,ACHSOB,ACHSPACC)=""

A1        ;

 +1        WRITE !!,"Date Of Service: "

 +2        IF ACHSSVDT

               WRITE $$FMTE^XLFDT(ACHSSVDT),"// "

 +3        DO READ^ACHSFU

 +4        IF $GET(ACHSQUIT)

               DO END

               QUIT 

 +5        IF Y?1"?".E

               WRITE !,"  Enter The Date The Patient First Received Treatment"

               GOTO A1

 +6        IF Y=""

               IF ACHSSVDT

                   GOTO A3

               WRITE !!,"Must enter Date of Service"

               GOTO A1

 +7        SET X=Y

           SET %DT="EXQP"

 +8        DO ^%DT

 +9        IF Y<1

               SET ACHSSVDT=""

               GOTO A1

 +10       IF Y<ACHSODT

               SET ACHSSVDT=Y

               WRITE *7,!,"SERVICE date is before ORDER date.",!

               GOTO A2

 +11       SET ACHSSVDT=Y

 +12       GOTO A3

 +13      ;

A2        ;

 +1        SET Y=$$DIR^XBDIR("Y","Are You Sure This Is Correct ","NO","","","",2)

 +2        IF $DATA(DTOUT)

               DO END

               QUIT 

 +3        IF $DATA(DUOUT)!('Y)

               GOTO A1

A3        ;

 +1        SET Y=$$DIR^XBDIR("N^1:9999:0","Workload Units",$GET(ACHSWKLD),""," Enter # of Visits, Days &/or Tests","",2)

 +2        IF $DATA(DTOUT)

               DO END

               QUIT 

 +3        IF $DATA(DUOUT)

               GOTO A1

 +4        SET ACHSWKLD=Y

 +5       ;

A3A       ; Set O/P visit to Hospital node

 +1       ;

 +2       ;GET OBJECT CLASSIFICATION PTR THEN GET CODE

 +3       ;254D = PHYS OUTP NON-IHS

 +4        IF $$DOC^ACHS(0,7)

               IF $PIECE(^ACHS(3,DUZ(2),1,$$DOC^ACHS(0,7),0),U)'="254D"

                   GOTO A4

 +5       ;GET PROVIDER (VENDOR) PTR THEN GET PROVIDER TYPE

 +6        IF $$DOC^ACHS(0,8)

               IF +$PIECE(^AUTTVNDR($$DOC^ACHS(0,8),11),U,3)'=""

                   IF $DATA(^AUTTVTYP(+$PIECE($GET(^AUTTVNDR($$DOC^ACHS(0,8),11)),U,3),0))

                       SET %=$PIECE(^(0),U)

                       IF (%="05")!(%="06")

                           GOTO A4

 +7        DO DIR("9002080.02,9.1^O",$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA,0)),U,16))

 +8        IF $DATA(DTOUT)

               DO END

               QUIT 

 +9        IF $DATA(DUOUT)

               GOTO A3

 +10      ;HOSPITAL OUTPATIENT

           SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA,0),U,16)=Y

A4        ;

 +1       ;

 +2       ;DOCUMENT PAYMENT ENTER/EDIT AMOUNT

           DO ^ACHSPAA

 +3       ;RETURNED VARS ACHSIPA,ACHSVAMT,ACHSPAMT   

           IF $DATA(DTOUT)

               DO END

               QUIT 

 +4        IF $DATA(DUOUT)

               GOTO A3

 +5       ;

 +6        IF +ACHSVAMT=0

               SET ACHSFULP="P"

               GOTO A6

A5        ;

 +1        SET ACHSFULP=$$DIR^XBDIR("9002080.02,4","Payment Status",$GET(ACHSFULP),"","","",2)

 +2        IF $DATA(DUOUT)

               GOTO A4

           IF $DATA(DTOUT)

               GOTO END

 +3        IF '$LENGTH(ACHSFULP)

               WRITE "  Required"

               GOTO A5

A6        ;

 +1        IF ACHSFULP="F"

               SET (ACHS3RDP,ACHS3RDS)=""

               GOTO A7A

A7        ;

 +1        WRITE !!,"Enter Amount Paid by all Third Parties: "

 +2        IF ACHS3RDP

               SET X=ACHS3RDP

               DO FMT^ACHS

               WRITE "//"

 +3        DO READ^ACHSFU

 +4        IF $DATA(DTOUT)

               DO END

               QUIT 

 +5        IF $DATA(DUOUT)

               GOTO A5

 +6        IF Y?1"?".E

               WRITE !," Enter difference between total bill and amount paid by IHS"

               GOTO A6

 +7        IF Y=""

               IF ACHS3RDP

                   GOTO SRC

 +8        SET ACHS3RDP=$JUSTIFY(Y,0,2)

 +9        WRITE "   ("

 +10       SET X=ACHS3RDP

 +11       DO FMT^ACHS

 +12       WRITE ")"

SRC       ; 3P source

 +1       ;'NAME' FROM 'INSURER'

           SET ACHS3RDS=$PIECE($GET(^AUTNINS(+$GET(ACHS3RDS),0)),U)

 +2        DO DIR("9002080.02,12^O",$GET(ACHS3RDS))

 +3        IF $DATA(DTOUT)

               DO END

               QUIT 

 +4        IF $DATA(DUOUT)

               GOTO A5

 +5        SET ACHS3RDS=$SELECT(+Y>0:+Y,1:"")

 +6       ;

A7A       ; Pay indicator: Final/Interim

 +1        IF '$DATA(ACHSF638)

               SET ACHSF638=$PIECE(^ACHSF(DUZ(2),0),U,8)

 +2        IF $$DOC^ACHS(0,17)="I"

               SET ACHSPIND="F"

               GOTO A7C

 +3        DO DIR("9002080.02,15",$$EXTSET^XBFUNC(9002080.02,15,$GET(ACHSPIND)))

 +4        IF $DATA(DUOUT)

               GOTO A5

           IF $DATA(DTOUT)

               GOTO END

 +5        IF '$LENGTH(Y)

               WRITE *7,"  Required"

               GOTO A7A

 +6        SET ACHSPIND=Y

 +7       ;

A7C       ; EOBR pay date

 +1       ;I ACHSF638="Y" S ACHSPDAT=DT G A8

 +2       ;ACHS*3.1*19 IHS/OIT.FCJ ADDED FOR TRIBAL SITES USING THE FI

           IF $$PARM^ACHS(2,11)'="Y"

               IF ACHSF638="Y"

                   SET ACHSPDAT=DT

                   GOTO A8

 +3        DO DIR("9002080.02,13",$$FMTE^XLFDT($GET(ACHSPDAT),1))

 +4        IF $DATA(DTOUT)

               DO END

               QUIT 

 +5        IF $DATA(DUOUT)

               GOTO A5

 +6        IF '$LENGTH(Y)

               WRITE *7,"  Required"

               GOTO A7C

 +7        SET ACHSPDAT=Y

 +8       ;DOCUMENT DESTINATION  F= FI

           IF $$DOC^ACHS(0,17)'="F"

               GOTO A8

 +9       ;

A7D       ; EOBR Control Number

 +1       ;G:ACHSF638="Y" A8

 +2       ;ACHS*3.1*19 IHS/OIT.FCJ ADDED FOR TRIBAL SITES USING THE FI

           IF $$PARM^ACHS(2,11)'="Y"

               IF ACHSF638="Y"

                   SET ACHSPDAT=DT

                   GOTO A8

 +3        DO DIR("9002080.02,16",$GET(ACHSCTL))

 +4        IF $DATA(DTOUT)

               DO END

               QUIT 

 +5        IF $DATA(DUOUT)

               GOTO A5

 +6        IF '$LENGTH(Y)

               WRITE *7,"  Required"

               GOTO A7D

 +7        SET ACHSCTL=Y

 +8       ;

A7E       ; EOBR Check number

 +1        DO DIR("9002080.02,17",$GET(ACHSCHK))

 +2        IF $DATA(DTOUT)

               DO END

               QUIT 

 +3        IF $DATA(DUOUT)

               GOTO A5

 +4        IF '$LENGTH(Y)

               WRITE *7,"  Required"

               GOTO A7E

 +5        SET ACHSCHK=Y

 +6       ;

A7F       ; EOBR Remittance number

 +1        DO DIR("9002080.02,18",$GET(ACHSREM))

 +2        IF $DATA(DTOUT)

               DO END

               QUIT 

 +3        IF $DATA(DUOUT)

               GOTO A5

 +4        IF '$LENGTH(Y)

               WRITE *7,"  Required"

               GOTO A7F

 +5        SET ACHSREM=Y

 +6       ;

A7G       ; EOBR Services

 +1        DO DIR("9002080.02,19",$$EXTSET^XBFUNC(9002080.02,19,$GET(ACHSSV)))

 +2        IF $DATA(DTOUT)

               DO END

               QUIT 

 +3        IF $DATA(DUOUT)

               GOTO A5

 +4        IF '$LENGTH(Y)

               WRITE *7,"  Required"

               GOTO A7G

 +5        SET ACHSSV=Y

 +6       ;

A7H       ; EOBR Obligation type

 +1        DO DIR("9002080.02,20",$$EXTSET^XBFUNC(9002080.02,20,$GET(ACHSOB)))

 +2        IF $DATA(DTOUT)

               DO END

               QUIT 

 +3        IF $DATA(DUOUT)

               GOTO A5

 +4        IF '$LENGTH(Y)

               WRITE *7,"  Required"

               GOTO A7H

 +5        SET ACHSOB=Y

 +6       ;

A8        ;

 +1       ;ITSC/SET/JVK 1.25.05 ACHS*3.1*12 NXT 4 LINES PATIENT ACCT NO

 +2        IF ACHSF638="Y"

               Begin DoDot:1

 +3                SET DIR(0)="9002080.01,26.01"

 +4                SET DIR("A")="Patient Account #"

 +5                DO ^DIR

 +6                SET ACHSPACC=Y

 +7                KILL DIR

 +8                QUIT 

               End DoDot:1

 +9        SET ACHSPSQN=$GET(^ACHSF(DUZ(2),"SEQN"))+1

 +10       SET ^ACHSF(DUZ(2),"SEQN")=ACHSPSQN

 +11       SET Y=$$DIR^XBDIR("Y","Are All Entries Correct","NO","","","",2)

 +12       IF $DATA(DTOUT)

               GOTO END

           IF $DATA(DUOUT)

               GOTO A3

           IF 'Y

               GOTO A1

 +13       SET ACHSSET=1

 +14       WRITE !!,"***  Document Paid  ***"

 +15       IF $PIECE(^ACHSF(DUZ(2),0),U,8)="Y"

               IF $PIECE(^(0),U,9)="Y"

                   SET ^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN)=""

                   WRITE !!,"***  Document added to Check-print list.  ***"

END       ;

 +1        KILL ACHSVAMT,X2,X3

 +2        QUIT 

 +3       ;

DIR(ACHS,ACHS1) ; ( <DIR(0)> , <DIR("B")> )

 +1        WRITE !

 +2        KILL DIR,DUOUT,DTOUT,DIRUT

 +3        SET DIR(0)=ACHS

 +4        IF $LENGTH($GET(ACHS1))

               SET DIR("B")=ACHS1

 +5        DO ^DIR

 +6        KILL DIR

 +7        QUIT 

 +8       ;