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
