ABSPOSQA ; IHS/FCS/DRS - POS background, Part 1 ;
;;1.0;PHARMACY POINT OF SALE;**10,42,43,46,47,48,49**;JUN 21, 2001;Build 38
;------------------------------------------------
;IHS/SD/lwj 03/10/04 patch 10
; Routine adjusted to call ABSPFUNC to retrieve
; and update Prescription Refill NDC value. At some
; point the call needs to be modified to call APSPFUNC.
; See ABSPFUNC for details on why call was done.
;------------------------------------------------
Q
ONE59 ;EP - from ABSPOSQ1
; Process this one IEN59 (was status 0, now status 10)
; MODULO also comes in from ABSPOSQ1
; MODULO,COUNT,ERROR were NEW'ed in ABSPOSQ1
;
S ERROR=0
N X S X=^ABSPT(IEN59,1)
N ABSBRXR,ABSBNDC,ABSBRXI
S ABSBRXR=$P(X,U),ABSBNDC=$P(X,U,2),ABSBRXI=$P(X,U,11)
I '$D(^PSRX(ABSBRXI,0)) S ERROR=101 G ERRJOIN
I ABSBRXR,'$D(^PSRX(ABSBRXI,1,ABSBRXR,0)) S ERROR=102 G ERRJOIN
;
I $E(IEN59,$L(IEN59))=1 D ; if it's a prescription claim,
. ; /IHS/OIT/RAM 6 OCT 17 - Always retrieve NDC info from claim -
. ; - disable ability to change NDC from POS claim screen. P49-CR09816
. I ABSBRXR S ABSBNDC=$$NDCVAL^ABSPFUNC(ABSBRXI,ABSBRXR) ;patch 10
. E S ABSBNDC=$P(^PSRX(ABSBRXI,2),U,7),ABSBNDC=$TR(ABSBNDC,"-")
. ; /IHS/OIT/RAM 6 OCT 17 disable all code below - NDC is now "read only." - P49-CR09816
. ; I ABSBNDC]"" D ; store NDC number if specified in the input
. . ; store in refill if this is a refill, otherwise store in main
. . ;IHS/SD/lwj 03/10/04 patch 10, nxt line rmkd out, new line added
. . ;I ABSBRXR S $P(^PSRX(ABSBRXI,1,ABSBRXR,0),U,13)=ABSBNDC
. . ; I ABSBRXR D RFNDC^ABSPFUNC(ABSBRXI,ABSBRXR,ABSBNDC) ;patch 10
. . ;IHS/SD/lwj 03/10/04 patch 10 end changes
. . ; E S $P(^PSRX(ABSBRXI,2),U,7)=ABSBNDC
. . ; and now that it's been stored, make it 11N for rest of proc'g
. . ; I ABSBNDC'?11N S ABSBNDC=$$NDCF^ABSPECFM(ABSBNDC)
. ; E D ; NDC number not specified, get it from prescription file
. . ;IHS/SD/lwj 03/10/04 patch 10, nxt line rmkd out, new line added
. . ;I ABSBRXR S ABSBNDC=$P(^PSRX(ABSBRXI,1,ABSBRXR,0),U,13)
. . ; I ABSBRXR S ABSBNDC=$$NDCVAL^ABSPFUNC(ABSBRXI,ABSBRXR) ;patch 10
. . ;IHS/SD/lwj 03/10/04 patch 10 end changes
. . ;IHS/OIT/CASSEVERN/RCS patch43 3/21/2012 Strip out the dashes
. . ; E S ABSBNDC=$P(^PSRX(ABSBRXI,2),U,7),ABSBNDC=$TR(ABSBNDC,"-")
;
; Set up lots of info about this claim
;
S ERROR=$$CLAIMINF^ABSPOSQB ; set up lots of info about this claim
I ERROR G ERRJOIN
;
; After setting up the extra info, update the status
; Change status to 30 to say "Ready to be put into a trasmit. packet"
;
; Check if the drug is billable
;
N INSIEN,DRUGIEN,NDCNUM,BILLABLE,BILLFLAG
S INSIEN=$P(^ABSPT(IEN59,1),U,6)
S DRUGIEN=$P(^PSRX(ABSBRXI,0),U,6)
S NDCNUM=$P(^ABSPT(IEN59,1),U,2)
;
ERRJOIN I ERROR D
. D SETSTAT(99)
. N ERRTEXT
. I ERROR=12 S ERRTEXT="PCC Link problem during visit lookup"
. E I ERROR=101 S ERRTEXT="Missing ^PSRX("_ABSBRXI_",0)"
. E I ERROR=102 S ERRTEXT="Missing ^PSRX("_ABSBRXI_",1,"_ABSBRXR_",0)"
. E I ERROR=105 S ERRTEXT="Missing ABSP PHARMACY link for Division" ; OIT/CAS/RCS 081213 Patch 46
. E I ERROR=106 S ERRTEXT="Missing Prescriber NPI Number" ; OIT/CAS/RCS 081913 Patch 46
. E S ERRTEXT="ERROR - see LOG"
. D SETRESU2(ERROR,ERRTEXT)
. D INCSTAT^ABSPOSUD("R",1) ; count how many Unbillable
E I '$$BILLABLE D ; the prescription/fill is marked as Manual bill
. D SETSTAT(99)
. D SETRESU2(1,"Prescription is marked for Manual Bill")
. D INCSTAT^ABSPOSUD("R",1) ; count how many Unbillable
E S BILLABLE=$$BILLABLE^ABSPOSQQ(INSIEN,DRUGIEN,NDCNUM) I 'BILLABLE D
. D LOG^ABSPOSL($P(BILLABLE,U,2))
. I $$BUMPINS(IEN59) D ; bump to next insurer
. . ; loop will pick up this claim again; don't need to task anything
. E D ; no more insurers
. . D SETRESU2(1,"Unbillable to ins.; "_$$ELGBEN_"; "_$P(BILLABLE,U,2))
. D INCSTAT^ABSPOSUD("R",1) ; count how many Unbillable
E I $$PAPER D
. D SETSTAT(99)
. N X,Y
. S X=$P(^ABSPT(IEN59,1),U,6)
. S Y=$S(X:$P(^AUTNINS(X,0),U),1:"")
. I Y="SELF PAY"!(Y="") D
. . S X="No insurance,"_$$ELGBEN
. E S X="Paper claim to "_$P(^AUTNINS(X,0),U)
. D SETRESU2(1,X) ; or statement or writeoff, to be det.
. D LOG^ABSPOSL(X)
. D INCSTAT^ABSPOSUD("R",1) ; count how many Unbillable
E D ; it's an electronic claim
. N STAT S STAT=30 ; new status will be 30 usually, or maybe 99 or 19
. I $P($G(^ABSP(9002313.99,1,"SPECIAL")),U) D
. . ; The special Oklahoma Medicaid rule is in effect
. . ; so hold Oklahoma Medicaid prescriptions a little longer
. . N INS S INS=$P(^ABSPT(IEN59,7),U)
. . I INS=$P(^ABSP(9002313.99,1,"SPECIAL"),U) S STAT=19
. D SETSTAT^ABSPOSQ1(STAT)
;
; Every so often, start up a packeter.
; We hope that for patients with many prescriptions,
; they'll be bundled into single packets.
;
I COUNT#MODULO=0 D PACKETER^ABSPOSQ1 ; start one up every Nth claim
;
Q
ELGBEN() ; construct ELG_","_BEN string ; given IEN59
N BEN,ELG,Y,I,X
S X=$P(^ABSPT(IEN59,0),U,6)
S X=$P($G(^AUPNPAT(X,11)),U,11,12)
I X="1^C"!(X="1^D") Q "Native ben."
S BEN=$P(X,U),ELG=$P(X,U,2)
I BEN S BEN=$P($G(^AUTTBEN(BEN,0)),U)
S X=$P(^DD(9000001,1112,0),U,3) ; set of codes detail
F I=1:1:$L(X,";") S Y=$P(X,";",I) I ELG=$P(Y,":") S ELG=$P(Y,":",2) Q
Q ELG_","_BEN
BUMPINS(IEN59) ;EP - ABSPOSQS
; bump up to the next insurer
; When you call this, be sure you have the logging slot set to
; the current prescription.
N INSIEN,MSG,PINPIECE,OLDINS ; return value is next insurer
S PINPIECE=$P(^ABSPT(IEN59,1),U,8)+1
I PINPIECE>$L($G(^ABSPT(IEN59,6)),U) S INSIEN=0
E S INSIEN=$P(^ABSPT(IEN59,7),U,PINPIECE)
S OLDINS=$P(^ABSPT(IEN59,1),U,6)
I 'OLDINS Q 0 ; we were already at the "no insurance" case
S $P(^ABSPT(IEN59,1),U,6)=INSIEN
S $P(^ABSPT(IEN59,1),U,8)=PINPIECE
I INSIEN D
. S MSG="Bump from insurer "_$$INSNAME(OLDINS)_" to "_$$INSNAME(INSIEN)
. I '$P($G(^ABSPT(IEN59,5)),U,6) D ; if price autocalc'd,
. . K ^ABSPT(IEN59,5) ; delete old insurer's pricing
. D SETSTAT^ABSPOSQ1(0) ; recompute the claim
;E D
I 'INSIEN D
. D SETSTAT^ABSPOSQ1(99) ; processing has gone as far as it can
. S MSG="Insurer "_$$INSNAME(OLDINS)_" was the last one."
D LOG^ABSPOSL(MSG)
Q INSIEN
INSNAME(N) I 'N Q "(no more insurances)"
Q $P($G(^AUTNINS(N,0)),U)
BILLABLE() ; per field 9999999.07 ; only at Pawhuska in the beginning
N RESULT
I ABSBRXR S RESULT=$P($G(^PSRX(ABSBRXI,1,ABSBRXR,9999999)),U,7)
E S RESULT=$P($G(^PSRX(ABSBRXI,9999999)),U,7)
I RESULT="" S RESULT=1 ; default to billable
I 'RESULT D ; Manual Bill is indicated in prescription file.
. N X S X=$P(^ABSPT(IEN59,0),U,14) ; ORIGIN
. I X=2!(X=3) S RESULT="1^Manual input, okay" Q
. S RESULT="0^Manual Bill is indicated in prescription file."
Q RESULT
;IHS/OIT CASSEVERN/RCS patch 43 3/7/2012 Added Billing Flag Check
BILLFLAG(INS) ; per field .23 of ^AUTNINS
N RESULT,CUR
S RESULT=1
I 'INS Q RESULT
S CUR=$P($G(^AUTNINS(INS,2)),U,3) ; current value
I CUR'="P" S RESULT=0
Q RESULT
FLAG23(INS,VAL) ; change field .23 of ^AUTNINS to appropriate value if needed
; A recent patch issued by (who? 3PBilling?) has a "P" value they want
N CUR S CUR=$P($G(^AUTNINS(INS,2)),U,3) ; current value
I VAL="P" D ; make sure "P" is supported (recent patch they issued)
. I $P($G(^DD(9999999.18,.23,0)),U,3)'["P:" S VAL="" ; nope, not yet
I CUR=VAL Q ; already set the value we want
;IHS/OIT CASSEVERN/RCS patch43 3/7/2012 Added 'O' and null so flag will not change
I CUR="U"!(CUR="O")!(CUR="") Q ; currently set to Unbillable for drugs? Can't be.
N FDA,MSG ; okay, we're going to change it
S FDA(9999999.18,INS_",",.23)=VAL
F23A D FILE^DIE(,"FDA","MSG")
I $D(MSG) D LOG^ABSPOSL2("F23A^ABSPOSQA",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q:'$D(MSG) ; success
D ZWRITE^ABSPOS("FDA","MSG")
G F23A:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"FLAG23",$T(+0))
Q
PAPER() ; Return TRUE if this has to be sent as a paper claim.
; Also take care of the ^AUTNINS field .23 flag "P" value
N INSURER,FORMAT,ACTDATE,FLAG23,BIN
S INSURER=+$P($G(^ABSPT(IEN59,1)),U,6)
;IHS/OIT/CASSEVERN/RAN patch42 3/31/2011 Added to prevent undefined error when insurer doesn't exist in ABSP INSURER file
;IHS/OIT/CASSEVERN/RCS patch43 3/2/2012 Moved variable set to fix If/Else problem in Patch 42
Q:'$D(^ABSPEI(INSURER)) 1
S (FORMAT,ACTDATE,FLAG23)=""
I INSURER D
. S FORMAT=$P($G(^ABSPEI(INSURER,100)),U),BIN=$P($G(^ABSPEI(INSURER,100)),U,16)
. S BILLFLAG=$$BILLFLAG(INSURER) I 'BILLFLAG S BIN="" ;IHS/OIT/CASSEVERN/RCS patch 43 3/21/2012 Check the Insurance flag if set as unbillable
. ;IHS/OIT/CASSEVERN/RCS patch 43 3/2/2012 Make sure if no BIN then FORMAT="", not real ins
. I FORMAT,'BIN,$G(^ABSP(9002313.99,1,"ABSPICNV"))=1 S FORMAT=""
. ;IHS/OIT/CASSEVERN/RAN patch42 3/30/2011 Added to prevent claims without format from going paper
. ;IHS/OIT CASSEVERN/RCS patch43 12/23/2011 Added BIN check to make sure valid Insurer
. I 'FORMAT,BIN,$G(^ABSP(9002313.99,1,"ABSPICNV"))=1 S FORMAT=1
. S ACTDATE=$P($G(^ABSPEI(INSURER,100)),U,3)
. S FLAG23=$P($G(^AUTNINS(INSURER,2)),U,3)
I FORMAT,ACTDATE'>DT D ; yes, this insurer is billed electronically
. D FLAG23(INSURER,"P")
E D
. Q:'INSURER ; uninsured
. D FLAG23(INSURER,"")
I 'FORMAT Q 1 ; not an electronic insurer
I ACTDATE>DT Q 1 ; not activated until some future date
; Looks like it's electronic but
; test some more (maybe electronic for presc. but paper for postage)
G @("PAPER"_$$TYPE^ABSPOSQ)
PAPER1 ; prescription
N P,L S P=$P(^ABSPT(IEN59,5),U,5) ; price
S L=$G(^ABSP(9002313.99,1,"DOLLMT")) I 'L S L=15000 ;OIT/CAS/RCS Patch 47, Add dollar limit check
;I P>0,P<10000 Q 0 ; make sure positive, and < $10000 (6 digits limit)
I P>0,P<L Q 0 ;OIT/CAS/RCS Patch 47, Make sure price is less than dollar limit
Q 1 ; otherwise, must go via paper
PAPER2 ; postage - depends on insurer and amount
N X S X=$G(^ABSPEI(INSURER,102))
I X="" Q 1 ; doesn't handle postage, must send by paper
I '$$RXI^ABSPOSQ,'$P(X,U,3) Q 1 ; supplies postage not allowed in POS
N AMT S AMT=$$AMT^ABSPOSQ
I $P(X,U,2)]"",AMT>$P(X,U,2) Q 1 ; exceeds maximum postage amount
Q 0 ; meets requirements for POS billing
PAPER3 ;
N X S X=$G(^ABSPEI(INSURER,103))
I X="" Q 1 ; doesn't handle supplies, must send by paper
Q 0 ; does handle supplies (as of 06/21/2000, we know of none that do)
SETSTAT(X) D SETSTAT^ABSPOSQ1(X) Q
SETRESU(RESCODE) ;
N ABSBRXI S ABSBRXI=IEN59 ; unfortunate variable name convention
D SETRESU^ABSPOSU(RESCODE) ;
Q
SETRESU2(RESCODE,RESTEXT) ;
N ABSBRXI S ABSBRXI=IEN59 ; unfortunate variable name convention
D SETRESU^ABSPOSU(RESCODE,RESTEXT)
Q
ABSPOSQA ; IHS/FCS/DRS - POS background, Part 1 ;
+1 ;;1.0;PHARMACY POINT OF SALE;**10,42,43,46,47,48,49**;JUN 21, 2001;Build 38
+2 ;------------------------------------------------
+3 ;IHS/SD/lwj 03/10/04 patch 10
+4 ; Routine adjusted to call ABSPFUNC to retrieve
+5 ; and update Prescription Refill NDC value. At some
+6 ; point the call needs to be modified to call APSPFUNC.
+7 ; See ABSPFUNC for details on why call was done.
+8 ;------------------------------------------------
+9 QUIT
ONE59 ;EP - from ABSPOSQ1
+1 ; Process this one IEN59 (was status 0, now status 10)
+2 ; MODULO also comes in from ABSPOSQ1
+3 ; MODULO,COUNT,ERROR were NEW'ed in ABSPOSQ1
+4 ;
+5 SET ERROR=0
+6 NEW X
SET X=^ABSPT(IEN59,1)
+7 NEW ABSBRXR,ABSBNDC,ABSBRXI
+8 SET ABSBRXR=$PIECE(X,U)
SET ABSBNDC=$PIECE(X,U,2)
SET ABSBRXI=$PIECE(X,U,11)
+9 IF '$DATA(^PSRX(ABSBRXI,0))
SET ERROR=101
GOTO ERRJOIN
+10 IF ABSBRXR
IF '$DATA(^PSRX(ABSBRXI,1,ABSBRXR,0))
SET ERROR=102
GOTO ERRJOIN
+11 ;
+12 ; if it's a prescription claim,
IF $EXTRACT(IEN59,$LENGTH(IEN59))=1
Begin DoDot:1
+13 ; /IHS/OIT/RAM 6 OCT 17 - Always retrieve NDC info from claim -
+14 ; - disable ability to change NDC from POS claim screen. P49-CR09816
+15 ;patch 10
IF ABSBRXR
SET ABSBNDC=$$NDCVAL^ABSPFUNC(ABSBRXI,ABSBRXR)
+16 IF '$TEST
SET ABSBNDC=$PIECE(^PSRX(ABSBRXI,2),U,7)
SET ABSBNDC=$TRANSLATE(ABSBNDC,"-")
+17 ; /IHS/OIT/RAM 6 OCT 17 disable all code below - NDC is now "read only." - P49-CR09816
+18 ; I ABSBNDC]"" D ; store NDC number if specified in the input
+19 ; store in refill if this is a refill, otherwise store in main
+20 ;IHS/SD/lwj 03/10/04 patch 10, nxt line rmkd out, new line added
+21 ;I ABSBRXR S $P(^PSRX(ABSBRXI,1,ABSBRXR,0),U,13)=ABSBNDC
+22 ; I ABSBRXR D RFNDC^ABSPFUNC(ABSBRXI,ABSBRXR,ABSBNDC) ;patch 10
+23 ;IHS/SD/lwj 03/10/04 patch 10 end changes
+24 ; E S $P(^PSRX(ABSBRXI,2),U,7)=ABSBNDC
+25 ; and now that it's been stored, make it 11N for rest of proc'g
+26 ; I ABSBNDC'?11N S ABSBNDC=$$NDCF^ABSPECFM(ABSBNDC)
+27 ; E D ; NDC number not specified, get it from prescription file
+28 ;IHS/SD/lwj 03/10/04 patch 10, nxt line rmkd out, new line added
+29 ;I ABSBRXR S ABSBNDC=$P(^PSRX(ABSBRXI,1,ABSBRXR,0),U,13)
+30 ; I ABSBRXR S ABSBNDC=$$NDCVAL^ABSPFUNC(ABSBRXI,ABSBRXR) ;patch 10
+31 ;IHS/SD/lwj 03/10/04 patch 10 end changes
+32 ;IHS/OIT/CASSEVERN/RCS patch43 3/21/2012 Strip out the dashes
+33 ; E S ABSBNDC=$P(^PSRX(ABSBRXI,2),U,7),ABSBNDC=$TR(ABSBNDC,"-")
End DoDot:1
+34 ;
+35 ; Set up lots of info about this claim
+36 ;
+37 ; set up lots of info about this claim
SET ERROR=$$CLAIMINF^ABSPOSQB
+38 IF ERROR
GOTO ERRJOIN
+39 ;
+40 ; After setting up the extra info, update the status
+41 ; Change status to 30 to say "Ready to be put into a trasmit. packet"
+42 ;
+43 ; Check if the drug is billable
+44 ;
+45 NEW INSIEN,DRUGIEN,NDCNUM,BILLABLE,BILLFLAG
+46 SET INSIEN=$PIECE(^ABSPT(IEN59,1),U,6)
+47 SET DRUGIEN=$PIECE(^PSRX(ABSBRXI,0),U,6)
+48 SET NDCNUM=$PIECE(^ABSPT(IEN59,1),U,2)
+49 ;
ERRJOIN IF ERROR
Begin DoDot:1
+1 DO SETSTAT(99)
+2 NEW ERRTEXT
+3 IF ERROR=12
SET ERRTEXT="PCC Link problem during visit lookup"
+4 IF '$TEST
IF ERROR=101
SET ERRTEXT="Missing ^PSRX("_ABSBRXI_",0)"
+5 IF '$TEST
IF ERROR=102
SET ERRTEXT="Missing ^PSRX("_ABSBRXI_",1,"_ABSBRXR_",0)"
+6 ; OIT/CAS/RCS 081213 Patch 46
IF '$TEST
IF ERROR=105
SET ERRTEXT="Missing ABSP PHARMACY link for Division"
+7 ; OIT/CAS/RCS 081913 Patch 46
IF '$TEST
IF ERROR=106
SET ERRTEXT="Missing Prescriber NPI Number"
+8 IF '$TEST
SET ERRTEXT="ERROR - see LOG"
+9 DO SETRESU2(ERROR,ERRTEXT)
+10 ; count how many Unbillable
DO INCSTAT^ABSPOSUD("R",1)
End DoDot:1
+11 ; the prescription/fill is marked as Manual bill
IF '$TEST
IF '$$BILLABLE
Begin DoDot:1
+12 DO SETSTAT(99)
+13 DO SETRESU2(1,"Prescription is marked for Manual Bill")
+14 ; count how many Unbillable
DO INCSTAT^ABSPOSUD("R",1)
End DoDot:1
+15 IF '$TEST
SET BILLABLE=$$BILLABLE^ABSPOSQQ(INSIEN,DRUGIEN,NDCNUM)
IF 'BILLABLE
Begin DoDot:1
+16 DO LOG^ABSPOSL($PIECE(BILLABLE,U,2))
+17 ; bump to next insurer
IF $$BUMPINS(IEN59)
Begin DoDot:2
+18 ; loop will pick up this claim again; don't need to task anything
End DoDot:2
+19 ; no more insurers
IF '$TEST
Begin DoDot:2
+20 DO SETRESU2(1,"Unbillable to ins.; "_$$ELGBEN_"; "_$P(BILLABLE,U,2))
End DoDot:2
+21 ; count how many Unbillable
DO INCSTAT^ABSPOSUD("R",1)
End DoDot:1
+22 IF '$TEST
IF $$PAPER
Begin DoDot:1
+23 DO SETSTAT(99)
+24 NEW X,Y
+25 SET X=$PIECE(^ABSPT(IEN59,1),U,6)
+26 SET Y=$SELECT(X:$PIECE(^AUTNINS(X,0),U),1:"")
+27 IF Y="SELF PAY"!(Y="")
Begin DoDot:2
+28 SET X="No insurance,"_$$ELGBEN
End DoDot:2
+29 IF '$TEST
SET X="Paper claim to "_$PIECE(^AUTNINS(X,0),U)
+30 ; or statement or writeoff, to be det.
DO SETRESU2(1,X)
+31 DO LOG^ABSPOSL(X)
+32 ; count how many Unbillable
DO INCSTAT^ABSPOSUD("R",1)
End DoDot:1
+33 ; it's an electronic claim
IF '$TEST
Begin DoDot:1
+34 ; new status will be 30 usually, or maybe 99 or 19
NEW STAT
SET STAT=30
+35 IF $PIECE($GET(^ABSP(9002313.99,1,"SPECIAL")),U)
Begin DoDot:2
+36 ; The special Oklahoma Medicaid rule is in effect
+37 ; so hold Oklahoma Medicaid prescriptions a little longer
+38 NEW INS
SET INS=$PIECE(^ABSPT(IEN59,7),U)
+39 IF INS=$PIECE(^ABSP(9002313.99,1,"SPECIAL"),U)
SET STAT=19
End DoDot:2
+40 DO SETSTAT^ABSPOSQ1(STAT)
End DoDot:1
+41 ;
+42 ; Every so often, start up a packeter.
+43 ; We hope that for patients with many prescriptions,
+44 ; they'll be bundled into single packets.
+45 ;
+46 ; start one up every Nth claim
IF COUNT#MODULO=0
DO PACKETER^ABSPOSQ1
+47 ;
+48 QUIT
ELGBEN() ; construct ELG_","_BEN string ; given IEN59
+1 NEW BEN,ELG,Y,I,X
+2 SET X=$PIECE(^ABSPT(IEN59,0),U,6)
+3 SET X=$PIECE($GET(^AUPNPAT(X,11)),U,11,12)
+4 IF X="1^C"!(X="1^D")
QUIT "Native ben."
+5 SET BEN=$PIECE(X,U)
SET ELG=$PIECE(X,U,2)
+6 IF BEN
SET BEN=$PIECE($GET(^AUTTBEN(BEN,0)),U)
+7 ; set of codes detail
SET X=$PIECE(^DD(9000001,1112,0),U,3)
+8 FOR I=1:1:$LENGTH(X,";")
SET Y=$PIECE(X,";",I)
IF ELG=$PIECE(Y,":")
SET ELG=$PIECE(Y,":",2)
QUIT
+9 QUIT ELG_","_BEN
BUMPINS(IEN59) ;EP - ABSPOSQS
+1 ; bump up to the next insurer
+2 ; When you call this, be sure you have the logging slot set to
+3 ; the current prescription.
+4 ; return value is next insurer
NEW INSIEN,MSG,PINPIECE,OLDINS
+5 SET PINPIECE=$PIECE(^ABSPT(IEN59,1),U,8)+1
+6 IF PINPIECE>$LENGTH($GET(^ABSPT(IEN59,6)),U)
SET INSIEN=0
+7 IF '$TEST
SET INSIEN=$PIECE(^ABSPT(IEN59,7),U,PINPIECE)
+8 SET OLDINS=$PIECE(^ABSPT(IEN59,1),U,6)
+9 ; we were already at the "no insurance" case
IF 'OLDINS
QUIT 0
+10 SET $PIECE(^ABSPT(IEN59,1),U,6)=INSIEN
+11 SET $PIECE(^ABSPT(IEN59,1),U,8)=PINPIECE
+12 IF INSIEN
Begin DoDot:1
+13 SET MSG="Bump from insurer "_$$INSNAME(OLDINS)_" to "_$$INSNAME(INSIEN)
+14 ; if price autocalc'd,
IF '$PIECE($GET(^ABSPT(IEN59,5)),U,6)
Begin DoDot:2
+15 ; delete old insurer's pricing
KILL ^ABSPT(IEN59,5)
End DoDot:2
+16 ; recompute the claim
DO SETSTAT^ABSPOSQ1(0)
End DoDot:1
+17 ;E D
+18 IF 'INSIEN
Begin DoDot:1
+19 ; processing has gone as far as it can
DO SETSTAT^ABSPOSQ1(99)
+20 SET MSG="Insurer "_$$INSNAME(OLDINS)_" was the last one."
End DoDot:1
+21 DO LOG^ABSPOSL(MSG)
+22 QUIT INSIEN
INSNAME(N) IF 'N
QUIT "(no more insurances)"
+1 QUIT $PIECE($GET(^AUTNINS(N,0)),U)
BILLABLE() ; per field 9999999.07 ; only at Pawhuska in the beginning
+1 NEW RESULT
+2 IF ABSBRXR
SET RESULT=$PIECE($GET(^PSRX(ABSBRXI,1,ABSBRXR,9999999)),U,7)
+3 IF '$TEST
SET RESULT=$PIECE($GET(^PSRX(ABSBRXI,9999999)),U,7)
+4 ; default to billable
IF RESULT=""
SET RESULT=1
+5 ; Manual Bill is indicated in prescription file.
IF 'RESULT
Begin DoDot:1
+6 ; ORIGIN
NEW X
SET X=$PIECE(^ABSPT(IEN59,0),U,14)
+7 IF X=2!(X=3)
SET RESULT="1^Manual input, okay"
QUIT
+8 SET RESULT="0^Manual Bill is indicated in prescription file."
End DoDot:1
+9 QUIT RESULT
+10 ;IHS/OIT CASSEVERN/RCS patch 43 3/7/2012 Added Billing Flag Check
BILLFLAG(INS) ; per field .23 of ^AUTNINS
+1 NEW RESULT,CUR
+2 SET RESULT=1
+3 IF 'INS
QUIT RESULT
+4 ; current value
SET CUR=$PIECE($GET(^AUTNINS(INS,2)),U,3)
+5 IF CUR'="P"
SET RESULT=0
+6 QUIT RESULT
FLAG23(INS,VAL) ; change field .23 of ^AUTNINS to appropriate value if needed
+1 ; A recent patch issued by (who? 3PBilling?) has a "P" value they want
+2 ; current value
NEW CUR
SET CUR=$PIECE($GET(^AUTNINS(INS,2)),U,3)
+3 ; make sure "P" is supported (recent patch they issued)
IF VAL="P"
Begin DoDot:1
+4 ; nope, not yet
IF $PIECE($GET(^DD(9999999.18,.23,0)),U,3)'["P:"
SET VAL=""
End DoDot:1
+5 ; already set the value we want
IF CUR=VAL
QUIT
+6 ;IHS/OIT CASSEVERN/RCS patch43 3/7/2012 Added 'O' and null so flag will not change
+7 ; currently set to Unbillable for drugs? Can't be.
IF CUR="U"!(CUR="O")!(CUR="")
QUIT
+8 ; okay, we're going to change it
NEW FDA,MSG
+9 SET FDA(9999999.18,INS_",",.23)=VAL
F23A DO FILE^DIE(,"FDA","MSG")
+1 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("F23A^ABSPOSQA",.MSG)
+2 ; success
IF '$DATA(MSG)
QUIT
+3 DO ZWRITE^ABSPOS("FDA","MSG")
+4 IF $$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"FLAG23",$TEXT(+0))
GOTO F23A
+5 QUIT
PAPER() ; Return TRUE if this has to be sent as a paper claim.
+1 ; Also take care of the ^AUTNINS field .23 flag "P" value
+2 NEW INSURER,FORMAT,ACTDATE,FLAG23,BIN
+3 SET INSURER=+$PIECE($GET(^ABSPT(IEN59,1)),U,6)
+4 ;IHS/OIT/CASSEVERN/RAN patch42 3/31/2011 Added to prevent undefined error when insurer doesn't exist in ABSP INSURER file
+5 ;IHS/OIT/CASSEVERN/RCS patch43 3/2/2012 Moved variable set to fix If/Else problem in Patch 42
+6 IF '$DATA(^ABSPEI(INSURER))
QUIT 1
+7 SET (FORMAT,ACTDATE,FLAG23)=""
+8 IF INSURER
Begin DoDot:1
+9 SET FORMAT=$PIECE($GET(^ABSPEI(INSURER,100)),U)
SET BIN=$PIECE($GET(^ABSPEI(INSURER,100)),U,16)
+10 ;IHS/OIT/CASSEVERN/RCS patch 43 3/21/2012 Check the Insurance flag if set as unbillable
SET BILLFLAG=$$BILLFLAG(INSURER)
IF 'BILLFLAG
SET BIN=""
+11 ;IHS/OIT/CASSEVERN/RCS patch 43 3/2/2012 Make sure if no BIN then FORMAT="", not real ins
+12 IF FORMAT
IF 'BIN
IF $GET(^ABSP(9002313.99,1,"ABSPICNV"))=1
SET FORMAT=""
+13 ;IHS/OIT/CASSEVERN/RAN patch42 3/30/2011 Added to prevent claims without format from going paper
+14 ;IHS/OIT CASSEVERN/RCS patch43 12/23/2011 Added BIN check to make sure valid Insurer
+15 IF 'FORMAT
IF BIN
IF $GET(^ABSP(9002313.99,1,"ABSPICNV"))=1
SET FORMAT=1
+16 SET ACTDATE=$PIECE($GET(^ABSPEI(INSURER,100)),U,3)
+17 SET FLAG23=$PIECE($GET(^AUTNINS(INSURER,2)),U,3)
End DoDot:1
+18 ; yes, this insurer is billed electronically
IF FORMAT
IF ACTDATE'>DT
Begin DoDot:1
+19 DO FLAG23(INSURER,"P")
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 ; uninsured
IF 'INSURER
QUIT
+22 DO FLAG23(INSURER,"")
End DoDot:1
+23 ; not an electronic insurer
IF 'FORMAT
QUIT 1
+24 ; not activated until some future date
IF ACTDATE>DT
QUIT 1
+25 ; Looks like it's electronic but
+26 ; test some more (maybe electronic for presc. but paper for postage)
+27 GOTO @("PAPER"_$$TYPE^ABSPOSQ)
PAPER1 ; prescription
+1 ; price
NEW P,L
SET P=$PIECE(^ABSPT(IEN59,5),U,5)
+2 ;OIT/CAS/RCS Patch 47, Add dollar limit check
SET L=$GET(^ABSP(9002313.99,1,"DOLLMT"))
IF 'L
SET L=15000
+3 ;I P>0,P<10000 Q 0 ; make sure positive, and < $10000 (6 digits limit)
+4 ;OIT/CAS/RCS Patch 47, Make sure price is less than dollar limit
IF P>0
IF P<L
QUIT 0
+5 ; otherwise, must go via paper
QUIT 1
PAPER2 ; postage - depends on insurer and amount
+1 NEW X
SET X=$GET(^ABSPEI(INSURER,102))
+2 ; doesn't handle postage, must send by paper
IF X=""
QUIT 1
+3 ; supplies postage not allowed in POS
IF '$$RXI^ABSPOSQ
IF '$PIECE(X,U,3)
QUIT 1
+4 NEW AMT
SET AMT=$$AMT^ABSPOSQ
+5 ; exceeds maximum postage amount
IF $PIECE(X,U,2)]""
IF AMT>$PIECE(X,U,2)
QUIT 1
+6 ; meets requirements for POS billing
QUIT 0
PAPER3 ;
+1 NEW X
SET X=$GET(^ABSPEI(INSURER,103))
+2 ; doesn't handle supplies, must send by paper
IF X=""
QUIT 1
+3 ; does handle supplies (as of 06/21/2000, we know of none that do)
QUIT 0
SETSTAT(X) DO SETSTAT^ABSPOSQ1(X)
QUIT
SETRESU(RESCODE) ;
+1 ; unfortunate variable name convention
NEW ABSBRXI
SET ABSBRXI=IEN59
+2 ;
DO SETRESU^ABSPOSU(RESCODE)
+3 QUIT
SETRESU2(RESCODE,RESTEXT) ;
+1 ; unfortunate variable name convention
NEW ABSBRXI
SET ABSBRXI=IEN59
+2 DO SETRESU^ABSPOSU(RESCODE,RESTEXT)
+3 QUIT
