ABSPOSPX.m

ABSPOSPX ; IHS/FCS/DRS - automatic writeoffs - criteria on form ;   [ 09/12/2002  10:18 AM ]

 ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38

 Q

 ; Continuation of ABSPOSPW - invoked indirectly by ^DIP

 ;

INCLUDE()          ; should D0 be included?

 S NINCLUDE=NINCLUDE+1

 I NINCLUDE#100=0 W "." W:$X>70 !

 N PCNDFN S PCNDFN=D0

 N VSTDFN S VSTDFN=$P($G(^ABSBITMS(9002302,PCNDFN,1,1,0)),U,3)

 N WATCH

 I +$H=58211,PCNDFN=131154!(PCNDFN=130550) S WATCH=PCNDFN

 I $G(WATCH) W "Watching ",PCNDFN,": "

 I $G(WATCH) W 4," "

 I '$$INC4 Q 0 ; age of account

 I $G(WATCH) W 5," "

 I '$$INC5 Q 0 ; date of service

 I $G(WATCH) W 1," "

 I '$$INC1 Q 0 ; insurers 

 I $G(WATCH) W 2," "

 I '$$INC2 Q 0 ; A/R type

 I $G(WATCH) W 3," "

 I '$$INC3 Q 0 ; balance, balance % of original

 I $G(WATCH) W 6," "

 I '$$INC6 Q 0 ; clinic

 I $G(WATCH) W 7," "

 I '$$INC7 Q 0 ; primary diagnosis

 I $G(WATCH) W 10," "

 I '$$INC10 Q 0 ; any payments

 I $G(WATCH) W "PASSED!",!

 Q 1

INC1() ; insurer

 I $P(PARAMS,U)=1 Q 1 ; all insurers

 N X S X=$P(^ABSBITMS(9002302,PCNDFN,0),U,3) ; AUDIT INSURER

 N IEN S IEN=$$INSIEN

 N ONLIST I IEN S ONLIST=$D(PARAMS("INS","B",IEN))

 E  S ONLIST=0

 I $P(PARAMS,U)=2 Q ONLIST ; only those on the list

 I $P(PARAMS,U)=3 Q 'ONLIST ; except those on the list

 D IMPOSS^ABSPOSUE("DB,P","TI","Bad PARAMS="_PARAMS,"piece 1","INC1",$T(+0))

 Q

INSIEN() ; Insurer IEN

 N X

 I '$D(^ABSBITMS(9002302,PCNDFN,"INSCOV1")) G OLD7

 N Y S Y=$P(^ABSBITMS(9002302,PCNDFN,0),U,4) ; internal audit insurer

 I 'Y S Y=1 ; default to #1

 ; INSIEN for new-style INSCOV1

 ; But you can't always trust the internal audit insurer! - so $GET it

 S X=$P($G(^ABSBITMS(9002302,PCNDFN,"INSCOV1",Y,1)),U,2)

 I X Q X

 ; not there?  try ^AUTNINS name lookup

 S X=$P(^ABSBITMS(9002302,PCNDFN,0),U,3)

 I X="" Q X

 Q $O(^AUTNINS("B",X,0))

OLD7 ; INSIEN for old-style INSCOV

 N Z S Z=$O(^ABSBITMS(9002302,PCNDFN,"INSCOV",Y,""))

 I Z="" Q ""

 N Z0 S Z0=^ABSBITMS(9002302,PCNDFN,"INSCOV",Y,Z,0)

 I Z="PRVT"!(Z="CAID") S X=$P(Z0,U,5)

 E  I Z="CARE"!(Z="RR") S X=$P(Z0,U,4) ; not sure about the RR

 E  S X=""

 Q X

INC2() ; a/r type

 I $P(PARAMS,U,2)=1 Q 1 ; all a/r types

 N X S X=$P(^ABSBITMS(9002302,PCNDFN,9),U,2) ; PCN TYPE

 N IEN S IEN=$O(^ABSBTYP("B",X,0))

 I 'IEN D IMPOSS^ABSPOSUE("DB,P","Bad A/R TYPE "_X,,"INC2",$T(+0))

 N ONLIST S ONLIST=$D(PARAMS("ARTYP","B",IEN))

 I $P(PARAMS,U)=2 Q ONLIST ; only those on the list

 I $P(PARAMS,U)=3 Q 'ONLIST ; except those on the list

 D IMPOSS^ABSPOSUE("DB,P","TI","Bad PARAMS="_PARAMS,"piece 1","INC1",$T(+0))

 Q ""

INC6() ; clinic

 I $P(PARAMS,U,6)=1 Q 1 ; all clinics

 I VSTDFN="" Q 1 ; should never happen

 N X S X=$P(^AUPNVSIT(VSTDFN,0),U,8)

 S ONLIST=$D(PARAMS("CLINIC","B",X))

 I $P(PARAMS,U,6)=2 Q ONLIST

 I $P(PARAMS,U,6)=3 Q 'ONLIST

 D IMPOSS^ABSPOSUE("DB,P","TI","Bad PARAMS="_PARAMS,"piece 6","INC6",$T(+0))

 Q ""

INC7() ; primary diagnosis

 I $P(PARAMS,U,7)=1 Q 1 ; any diagnosis

 N X S X=$$DIAG

 I 'X S ONLIST=0

 E  S ONLIST=$D(PARAMS("DIAG","B",X))

 I $P(PARAMS,U,7)=2 Q ONLIST

 I $P(PARAMS,U,7)=3 Q 'ONLIST

 D IMPOSS^ABSPOSUE("DB,P","TI","Bad PARAMS="_PARAMS,"pieces 7","INC7",$T(+0))

 Q ""

DIAG() ; find primary diagnosis for VSTDFN

 I VSTDFN="" Q 1 ; should never happen

 N X S X=$O(^ABSBV(VSTDFN,"FSICD9",0)) ; in V VISIT file?

 I X Q $P(^ABSBV(VSTDFN,"FSICD9",X,0),U)

 ; else look in V POV file for first one marked primary

 N IEN S IEN=0

 F  S IEN=$O(^AUPNVPOV("AD",VSTDFN,IEN)) Q:'IEN  D  Q:X

 . I $P(^AUPNVPOV(IEN,0),U,12)="P" S X=$P(^(0),U)

 Q X

INC10() ; include only if there's been a payment by current insurer

 ; useful, for example, if you want to write off Medicaid RX

 ; after getting whatever Medicaid paid

 N TYPE S TYPE=$P(PARAMS,U,11)

 I $G(WATCH) D ZWRITE^ABSPOS("TYPE")

 I 'TYPE Q 1 ; don't consider payments record

 I TYPE=1 N INSIEN S INSIEN=$$INSIEN ; insist on payment from this ins

 I $G(WATCH) D ZWRITE^ABSPOS("INSIEN")

 N RET S RET=0

 N X S X=0

 F  S X=$O(^ABSBITMS(9002302,PCNDFN,7,X)) Q:'X  D  Q:RET

 . I $G(WATCH) W "Examining payment node #",X,!

 . I TYPE=2 S RET=1 Q  ; yes, a payment, and we don't care who paid

 . I $P(^ABSBITMS(9002302,PCNDFN,7,X,0),U,3)=INSIEN S RET=1

 I $G(WATCH) D ZWRITE^ABSPOS("RET")

 Q RET

INC3() ; balance

 N MIN,MAX,PCT

 S MIN=$P(PARAMS,U,3),MAX=$P(PARAMS,U,4),PCT=$P(PARAMS,U,9)/100

 I MIN="",MAX="",PCT="" Q 1

 N BAL S BAL=$P(^ABSBITMS(9002302,PCNDFN,3),U)

 N ORIG S ORIG=$P(^ABSBITMS(9002302,PCNDFN,1,1,0),U,4)

 I $G(WATCH) D

 . D ZWRITE^ABSPOS("MIN","MAX","PCT","BAL")

 . I ORIG W "BAL/ORIG=",BAL/ORIG,!

 I 'BAL Q 0  ; shouldn't happen; zero balance account s/b inactive

 I MIN]"",BAL<MIN Q 0

 I MAX]"",BAL>MAX Q 0

 I 'PCT Q 0

 I 'ORIG Q 1 ; impossible?

 N X S X=BAL/ORIG S:X<0 X=-X S:X>1 X=1

 Q X'>PCT

INC4() ; aging date

 N X S X=$G(PARAMS("AGING DATE < THIS")) Q:'X 1

 N Y S Y=$P($G(^ABSBITMS(9002302,PCNDFN,"AGE")),U) Q:'Y 1

 Q Y<X ; true if account's aging date < specified date

INC5() ; date of service

 N X S X=$P(PARAMS,U,8) Q:'X 1 ; dates of service prior to this

 I VSTDFN="" Q 1 ; should never happen

 N Y S Y=$P($G(^AUPNVSIT(VSTDFN,0)),U) Q:'Y 1

 Q Y<X ; true if date of service < specified date

ACTIVBAT() ;EP - returns true if there's an active batch outstanding

 ; from this program's operation

 N X S X=$P($G(^ABSP(9002313.99,1,"WRITEOFF-SCREEN BATCH")),U)

 I X="" Q "" ; no batch in progress (first time program has been run)

 I '$D(^ABSBPMNT(X)) Q "" ; batch is undefined?!

 N Y S Y=$P(^ABSBPMNT(X,0),U,5) ; batch status

 I Y="R"!(Y="C") Q "" ; released or canceled, okay

 Q X ; return batch number

ABSPOSPX  ; IHS/FCS/DRS - automatic writeoffs - criteria on form ;   [ 09/12/2002  10:18 AM ]

 +1       ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38

 +2        QUIT 

 +3       ; Continuation of ABSPOSPW - invoked indirectly by ^DIP

 +4       ;

INCLUDE() ; should D0 be included?

 +1        SET NINCLUDE=NINCLUDE+1

 +2        IF NINCLUDE#100=0

               WRITE "."

               IF $X>70

                   WRITE !

 +3        NEW PCNDFN

           SET PCNDFN=D0

 +4        NEW VSTDFN

           SET VSTDFN=$PIECE($GET(^ABSBITMS(9002302,PCNDFN,1,1,0)),U,3)

 +5        NEW WATCH

 +6        IF +$HOROLOG=58211

               IF PCNDFN=131154!(PCNDFN=130550)

                   SET WATCH=PCNDFN

 +7        IF $GET(WATCH)

               WRITE "Watching ",PCNDFN,": "

 +8        IF $GET(WATCH)

               WRITE 4," "

 +9       ; age of account

           IF '$$INC4

               QUIT 0

 +10       IF $GET(WATCH)

               WRITE 5," "

 +11      ; date of service

           IF '$$INC5

               QUIT 0

 +12       IF $GET(WATCH)

               WRITE 1," "

 +13      ; insurers 

           IF '$$INC1

               QUIT 0

 +14       IF $GET(WATCH)

               WRITE 2," "

 +15      ; A/R type

           IF '$$INC2

               QUIT 0

 +16       IF $GET(WATCH)

               WRITE 3," "

 +17      ; balance, balance % of original

           IF '$$INC3

               QUIT 0

 +18       IF $GET(WATCH)

               WRITE 6," "

 +19      ; clinic

           IF '$$INC6

               QUIT 0

 +20       IF $GET(WATCH)

               WRITE 7," "

 +21      ; primary diagnosis

           IF '$$INC7

               QUIT 0

 +22       IF $GET(WATCH)

               WRITE 10," "

 +23      ; any payments

           IF '$$INC10

               QUIT 0

 +24       IF $GET(WATCH)

               WRITE "PASSED!",!

 +25       QUIT 1

INC1()    ; insurer

 +1       ; all insurers

           IF $PIECE(PARAMS,U)=1

               QUIT 1

 +2       ; AUDIT INSURER

           NEW X

           SET X=$PIECE(^ABSBITMS(9002302,PCNDFN,0),U,3)

 +3        NEW IEN

           SET IEN=$$INSIEN

 +4        NEW ONLIST

           IF IEN

               SET ONLIST=$DATA(PARAMS("INS","B",IEN))

 +5       IF '$TEST

               SET ONLIST=0

 +6       ; only those on the list

           IF $PIECE(PARAMS,U)=2

               QUIT ONLIST

 +7       ; except those on the list

           IF $PIECE(PARAMS,U)=3

               QUIT 'ONLIST

 +8        DO IMPOSS^ABSPOSUE("DB,P","TI","Bad PARAMS="_PARAMS,"piece 1","INC1",$TEXT(+0))

 +9        QUIT 

INSIEN()  ; Insurer IEN

 +1        NEW X

 +2        IF '$DATA(^ABSBITMS(9002302,PCNDFN,"INSCOV1"))

               GOTO OLD7

 +3       ; internal audit insurer

           NEW Y

           SET Y=$PIECE(^ABSBITMS(9002302,PCNDFN,0),U,4)

 +4       ; default to #1

           IF 'Y

               SET Y=1

 +5       ; INSIEN for new-style INSCOV1

 +6       ; But you can't always trust the internal audit insurer! - so $GET it

 +7        SET X=$PIECE($GET(^ABSBITMS(9002302,PCNDFN,"INSCOV1",Y,1)),U,2)

 +8        IF X

               QUIT X

 +9       ; not there?  try ^AUTNINS name lookup

 +10       SET X=$PIECE(^ABSBITMS(9002302,PCNDFN,0),U,3)

 +11       IF X=""

               QUIT X

 +12       QUIT $ORDER(^AUTNINS("B",X,0))

OLD7      ; INSIEN for old-style INSCOV

 +1        NEW Z

           SET Z=$ORDER(^ABSBITMS(9002302,PCNDFN,"INSCOV",Y,""))

 +2        IF Z=""

               QUIT ""

 +3        NEW Z0

           SET Z0=^ABSBITMS(9002302,PCNDFN,"INSCOV",Y,Z,0)

 +4        IF Z="PRVT"!(Z="CAID")

               SET X=$PIECE(Z0,U,5)

 +5       ; not sure about the RR

          IF '$TEST

               IF Z="CARE"!(Z="RR")

                   SET X=$PIECE(Z0,U,4)

 +6       IF '$TEST

               SET X=""

 +7        QUIT X

INC2()    ; a/r type

 +1       ; all a/r types

           IF $PIECE(PARAMS,U,2)=1

               QUIT 1

 +2       ; PCN TYPE

           NEW X

           SET X=$PIECE(^ABSBITMS(9002302,PCNDFN,9),U,2)

 +3        NEW IEN

           SET IEN=$ORDER(^ABSBTYP("B",X,0))

 +4        IF 'IEN

               DO IMPOSS^ABSPOSUE("DB,P","Bad A/R TYPE "_X,,"INC2",$TEXT(+0))

 +5        NEW ONLIST

           SET ONLIST=$DATA(PARAMS("ARTYP","B",IEN))

 +6       ; only those on the list

           IF $PIECE(PARAMS,U)=2

               QUIT ONLIST

 +7       ; except those on the list

           IF $PIECE(PARAMS,U)=3

               QUIT 'ONLIST

 +8        DO IMPOSS^ABSPOSUE("DB,P","TI","Bad PARAMS="_PARAMS,"piece 1","INC1",$TEXT(+0))

 +9        QUIT ""

INC6()    ; clinic

 +1       ; all clinics

           IF $PIECE(PARAMS,U,6)=1

               QUIT 1

 +2       ; should never happen

           IF VSTDFN=""

               QUIT 1

 +3        NEW X

           SET X=$PIECE(^AUPNVSIT(VSTDFN,0),U,8)

 +4        SET ONLIST=$DATA(PARAMS("CLINIC","B",X))

 +5        IF $PIECE(PARAMS,U,6)=2

               QUIT ONLIST

 +6        IF $PIECE(PARAMS,U,6)=3

               QUIT 'ONLIST

 +7        DO IMPOSS^ABSPOSUE("DB,P","TI","Bad PARAMS="_PARAMS,"piece 6","INC6",$TEXT(+0))

 +8        QUIT ""

INC7()    ; primary diagnosis

 +1       ; any diagnosis

           IF $PIECE(PARAMS,U,7)=1

               QUIT 1

 +2        NEW X

           SET X=$$DIAG

 +3        IF 'X

               SET ONLIST=0

 +4       IF '$TEST

               SET ONLIST=$DATA(PARAMS("DIAG","B",X))

 +5        IF $PIECE(PARAMS,U,7)=2

               QUIT ONLIST

 +6        IF $PIECE(PARAMS,U,7)=3

               QUIT 'ONLIST

 +7        DO IMPOSS^ABSPOSUE("DB,P","TI","Bad PARAMS="_PARAMS,"pieces 7","INC7",$TEXT(+0))

 +8        QUIT ""

DIAG()    ; find primary diagnosis for VSTDFN

 +1       ; should never happen

           IF VSTDFN=""

               QUIT 1

 +2       ; in V VISIT file?

           NEW X

           SET X=$ORDER(^ABSBV(VSTDFN,"FSICD9",0))

 +3        IF X

               QUIT $PIECE(^ABSBV(VSTDFN,"FSICD9",X,0),U)

 +4       ; else look in V POV file for first one marked primary

 +5        NEW IEN

           SET IEN=0

 +6        FOR 

               SET IEN=$ORDER(^AUPNVPOV("AD",VSTDFN,IEN))

               IF 'IEN

                   QUIT 

               Begin DoDot:1

 +7                IF $PIECE(^AUPNVPOV(IEN,0),U,12)="P"

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

               End DoDot:1

               IF X

                   QUIT 

 +8        QUIT X

INC10()   ; include only if there's been a payment by current insurer

 +1       ; useful, for example, if you want to write off Medicaid RX

 +2       ; after getting whatever Medicaid paid

 +3        NEW TYPE

           SET TYPE=$PIECE(PARAMS,U,11)

 +4        IF $GET(WATCH)

               DO ZWRITE^ABSPOS("TYPE")

 +5       ; don't consider payments record

           IF 'TYPE

               QUIT 1

 +6       ; insist on payment from this ins

           IF TYPE=1

               NEW INSIEN

               SET INSIEN=$$INSIEN

 +7        IF $GET(WATCH)

               DO ZWRITE^ABSPOS("INSIEN")

 +8        NEW RET

           SET RET=0

 +9        NEW X

           SET X=0

 +10       FOR 

               SET X=$ORDER(^ABSBITMS(9002302,PCNDFN,7,X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +11               IF $GET(WATCH)

                       WRITE "Examining payment node #",X,!

 +12      ; yes, a payment, and we don't care who paid

                   IF TYPE=2

                       SET RET=1

                       QUIT 

 +13               IF $PIECE(^ABSBITMS(9002302,PCNDFN,7,X,0),U,3)=INSIEN

                       SET RET=1

               End DoDot:1

               IF RET

                   QUIT 

 +14       IF $GET(WATCH)

               DO ZWRITE^ABSPOS("RET")

 +15       QUIT RET

INC3()    ; balance

 +1        NEW MIN,MAX,PCT

 +2        SET MIN=$PIECE(PARAMS,U,3)

           SET MAX=$PIECE(PARAMS,U,4)

           SET PCT=$PIECE(PARAMS,U,9)/100

 +3        IF MIN=""

               IF MAX=""

                   IF PCT=""

                       QUIT 1

 +4        NEW BAL

           SET BAL=$PIECE(^ABSBITMS(9002302,PCNDFN,3),U)

 +5        NEW ORIG

           SET ORIG=$PIECE(^ABSBITMS(9002302,PCNDFN,1,1,0),U,4)

 +6        IF $GET(WATCH)

               Begin DoDot:1

 +7                DO ZWRITE^ABSPOS("MIN","MAX","PCT","BAL")

 +8                IF ORIG

                       WRITE "BAL/ORIG=",BAL/ORIG,!

               End DoDot:1

 +9       ; shouldn't happen; zero balance account s/b inactive

           IF 'BAL

               QUIT 0

 +10       IF MIN]""

               IF BAL<MIN

                   QUIT 0

 +11       IF MAX]""

               IF BAL>MAX

                   QUIT 0

 +12       IF 'PCT

               QUIT 0

 +13      ; impossible?

           IF 'ORIG

               QUIT 1

 +14       NEW X

           SET X=BAL/ORIG

           IF X<0

               SET X=-X

           IF X>1

               SET X=1

 +15       QUIT X'>PCT

INC4()    ; aging date

 +1        NEW X

           SET X=$GET(PARAMS("AGING DATE < THIS"))

           IF 'X

               QUIT 1

 +2        NEW Y

           SET Y=$PIECE($GET(^ABSBITMS(9002302,PCNDFN,"AGE")),U)

           IF 'Y

               QUIT 1

 +3       ; true if account's aging date < specified date

           QUIT Y<X

INC5()    ; date of service

 +1       ; dates of service prior to this

           NEW X

           SET X=$PIECE(PARAMS,U,8)

           IF 'X

               QUIT 1

 +2       ; should never happen

           IF VSTDFN=""

               QUIT 1

 +3        NEW Y

           SET Y=$PIECE($GET(^AUPNVSIT(VSTDFN,0)),U)

           IF 'Y

               QUIT 1

 +4       ; true if date of service < specified date

           QUIT Y<X

ACTIVBAT() ;EP - returns true if there's an active batch outstanding

 +1       ; from this program's operation

 +2        NEW X

           SET X=$PIECE($GET(^ABSP(9002313.99,1,"WRITEOFF-SCREEN BATCH")),U)

 +3       ; no batch in progress (first time program has been run)

           IF X=""

               QUIT ""

 +4       ; batch is undefined?!

           IF '$DATA(^ABSBPMNT(X))

               QUIT ""

 +5       ; batch status

           NEW Y

           SET Y=$PIECE(^ABSBPMNT(X,0),U,5)

 +6       ; released or canceled, okay

           IF Y="R"!(Y="C")

               QUIT ""

 +7       ; return batch number

           QUIT X