Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPOSQA

ABSPOSQA.m

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