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

ABSPOSCD.m

Go to the documentation of this file. 
  1. ABSPOSCD ; IHS/FCS/DRS - ABSP("RX",*) ;      [ 10/28/2002  2:40 PM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3,10,12,18,19,20,21,23,32,36,40,42,46**;JUN 21, 2001;Build 38
  1.  ;---
  1.  ;IHS/SD/lwj 8/20/02  NCPDP 5.1 changes
  1.  ; One of the new segments in 5.1 is the DUR/PPS segment - this 
  1.  ; entire segment is comprised of repeating fields.  It's values 
  1.  ; will originate in the ABSP DUR/PPS file, which will be 
  1.  ; linked to the prescription via the 9999999.13 DUR/PPS Pointer
  1.  ; field in the PSRX file. For POS, this pointer is stored
  1.  ; in the ^ABSPT(D0,1) global - piece 14.  If there is a value
  1.  ; in this field, and we are working with a 5.1 claim we have
  1.  ; altered this routine to retrieve the values from the ABSP DUR/PPS
  1.  ; file and store them in the ABSP("RX",MEDN,DURN,...) array.
  1.  ;
  1.  ; Prior authorization is now being done differently.  For 3.2 claims
  1.  ; the value is stored in field 416 - in 5.1, it is split into a type
  1.  ; stored in field 461 and the number, which is stored in 462.  Changes
  1.  ; were made to reduce the complexity of the formulation of field 416.
  1.  ; For now, fields 416, 461, and 462 will all be populated.
  1.  ;
  1.  ;---
  1.  ;IHS/SD/lwj 03/10/04 patch 10
  1.  ; Routine adjusted to call ABSPFUNC to retrieve
  1.  ; the 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.  ;IHS/SD/lwj 5/24/05 patch 12
  1.  ; Need to retrieve prescriber's last name for OK Medicaid
  1.  ; Retrieve Payer Assigned Provider Number for WA L & I
  1.  ;---
  1.  ;IHS/SD/RLT - 7/18/06 - Patch 18
  1.  ; Added code for ABSP("Claim",MEDN,"Unit of Measure")
  1.  ;---
  1.  ;IHS/SD/RLT - 12/19/06 - Patch 19
  1.  ; Added code for ABSP("Basis of Cost Determination")
  1.  ;---
  1.  ;IHS/SD/RLT - 03/15/07 - Patch 20
  1.  ; NPI
  1.  ;---
  1.  ;IHS/SD/RLT - 05/14/07 - Patch 21
  1.  ; Updated NPI
  1.  ;---
  1.  ;IHS/SD/RLT - 06/27/07 - 10/18/07 - Patch 23
  1.  ; New tag DIAGVAL for Diagnosis Code.
  1.  Q
  1.  ;----------------------------------------------------------------------
  1.  ;Set ABSP() "RX" nodes for current medication:
  1.  ;
  1.  ;Parameters:   VMEDINFO  - Contains VMEDIEN,RXIEN,RXRFIEN,VCPTIEN
  1.  ;              MEDN      - Index number indicating what medication is
  1.  ;                          being processed
  1.  ;----------------------------------------------------------------------
  1.  ; Called from ABSPOSCA from ABSPOSQG from ABSPOSQ2,
  1.  ; once for each item in its VMEDS() array.
  1. MEDINFO(VMEDINFO,MEDN,INSPINS) ;EP
  1.  ;Manage local variables
  1.  N VMEDIEN,RXIEN,RXRFIEN,DRUGIEN,PROVIEN,VCPTIEN,RXI,IEN59,PINSTYPE
  1.  N UOM        ;IHS/SD/RLT - 7/18/06 - Patch 18
  1.  ;
  1.  ;Parse variables from VMEDINFO variable
  1.  S VMEDIEN=$P(VMEDINFO,U,1)
  1.  S RXIEN=$P(VMEDINFO,U,2)
  1.  S RXRFIEN=$P(VMEDINFO,U,3)
  1.  S VCPTIEN=$P(VMEDINFO,U,4)
  1.  S IEN59=$P(VMEDINFO,U,5) ; 06/23/2000
  1.  D OVERRIDE(IEN59,MEDN) ; overrides stored in 9002313.511
  1.  ;
  1.  ;IHS/SD/lwj 8/20/02  NCPDP 5.1 changes - if a 5.1 claims and
  1.  ; there are DUR values - retrieve them
  1.  I ABSP("NCPDP","Version")'[3 D DURVALUE(IEN59,MEDN)
  1.  ;
  1.  ;IHS/SD/RLT - 06/27/07 - 10/18/07 - Patch 23
  1.  ; Diagnosis Code
  1.  I ABSP("NCPDP","Version")'[3 D DIAGVAL(IEN59,MEDN)
  1.  ;
  1.  S PINSTYPE=$P(INSPINS,",") ; "CAID" will make a difference
  1.  ;
  1.  S DRUGIEN=$P($G(^PSRX(RXIEN,0)),U,6)
  1.  S PROVIEN=$P($G(^PSRX(RXIEN,0)),U,4)
  1.  ;
  1.  S ABSP("RX",MEDN,"VCPT IEN")=VCPTIEN
  1.  S ABSP("RX",MEDN,"IEN59")=IEN59 ; 06/23/2000
  1.  S (RXI,ABSP("RX",MEDN,"RX IEN"))=RXIEN
  1.  S ABSP("RX",MEDN,"Date Written")=$P($G(^PSRX(RXIEN,0)),U,13)
  1.  S ABSP("RX",MEDN,"RX Number")=RXIEN ;$P($G(^PSRX(RXIEN,0)),U,1)
  1.  S ABSP("RX",MEDN,"New/Refill")=$S(RXRFIEN="":"N",1:"R")
  1.  ;
  1.  ;IHS/SD/lwj 8/30/02  NCPDP 5.1 changes 
  1.  ; Version 3.2 uses field 416 for the prior auth code and number
  1.  ; Version 5.1 will use fields 461 and 462
  1.  ; Below line remarked out, next three lines added
  1.  ;
  1.  ;  S ABSP("RX",MEDN,"Preauth #")=$P(^ABSPT(IEN59,1),U,9)  ;obsolete
  1.  S ABSP("RX",MEDN,"Preauth #")=$P(^ABSPT(IEN59,1),U,15)_$P(^ABSPT(IEN59,1),U,9)
  1.  S ABSP("Claim",MEDN,"Prior Auth Type")=$P(^ABSPT(IEN59,1),U,15)
  1.  S ABSP("Claim",MEDN,"Prior Auth Num Sub")=$P(^ABSPT(IEN59,1),U,9)
  1.  ;
  1.  ;IHS/OIT/SCR 060909 - Get 419 value - start changes
  1.  ;S ABSPORGN=$$ISPOE(RXIEN)
  1.  S ABSPORGN=$$ISOR1^ABSPFUNC(RXIEN) ;IHS/CAS/RCS 090913 Patch 46 New way of finding Field 419, else use original
  1.  I ABSPORGN="" S ABSPORGN=$$ISPOE^APSPFUNC(RXIEN) ;IHS/OIT/SCR 011110 patch 36
  1.  S:ABSPORGN=1 ABSP("RX",MEDN,"Origin Code")=3 ;ELECTRONIC - if not controlled substance and entered through EHR
  1.  S:ABSPORGN=0 ABSP("RX",MEDN,"Origin Code")=1 ;WRITTEN - required for controlled substances
  1.  ;IHS/OIT/SCR 060909 end changes
  1.  I 'RXRFIEN D  ; first fill
  1.  .S ABSP("RX",MEDN,"Quantity")=$P($G(^PSRX(RXIEN,0)),U,7)
  1.  .S ABSP("RX",MEDN,"Days Supply")=$P($G(^PSRX(RXIEN,0)),U,8)
  1.  .S ABSP("RX",MEDN,"Date Filled")=$P($G(^PSRX(RXIEN,2)),U,2)
  1.  .S ABSP("RX",MEDN,"NDC")=$P($G(^PSRX(RXIEN,2)),U,7)
  1.  E  D  ; refill
  1.  .S ABSP("RX",MEDN,"Quantity")=$P($G(^PSRX(RXIEN,1,RXRFIEN,0)),U,4)
  1.  .S ABSP("RX",MEDN,"Days Supply")=$P($G(^PSRX(RXIEN,1,RXRFIEN,0)),U,10)
  1.  .S ABSP("RX",MEDN,"Date Filled")=$P($G(^PSRX(RXIEN,1,RXRFIEN,0)),U)
  1.  .;IHS/SD/lwj 03/10/04 patch 10 nxt line rmkd out, new line added
  1.  .;S ABSP("RX",MEDN,"NDC")=$P($G(^PSRX(RXIEN,1,RXRFIEN,0)),U,13)
  1.  .S ABSP("RX",MEDN,"NDC")=$$NDCVAL^ABSPFUNC(RXIEN,RXRFIEN)  ;patch 10
  1.  .;IHS/SD/lwj 03/10/04 patch 10 end change
  1.  ;IHS/OIT/CNI/RAN PATCH 40 This is the proper fill date
  1.  S ABSP("RX","Date Filled")=ABSP("RX",MEDN,"Date Filled")
  1.  ;Add new fields;Patch 42
  1.  S OCNT=0 I $G(ABSP("OVERRIDE","RX",MEDN,30))]"" D
  1.  .S ABSP("RX",MEDN,"Subm Clar Code 1")=$P(ABSP("OVERRIDE","RX",MEDN,30),",") I ABSP("RX",MEDN,"Subm Clar Code 1")]"" S OCNT=OCNT+1
  1.  .S ABSP("RX",MEDN,"Subm Clar Code 2")=$P(ABSP("OVERRIDE","RX",MEDN,30),",",2) I ABSP("RX",MEDN,"Subm Clar Code 2")]"" S OCNT=OCNT+1
  1.  .S ABSP("RX",MEDN,"Subm Clar Code 3")=$P(ABSP("OVERRIDE","RX",MEDN,30),",",3) I ABSP("RX",MEDN,"Subm Clar Code 3")]"" S OCNT=OCNT+1
  1.  .I OCNT S ABSP("RX",MEDN,"Subm Clar Count")=OCNT
  1.  ;
  1.  ;OIT/CAS/RCS 110113 Patch 46, Create Dx Clinic segment from NCPDP Overrides, HEAT #135659, On hold
  1.  ;I $G(ABSP("OVERRIDE","RX",MEDN,492))=99,$G(ABSP("OVERRIDE","RX",MEDN,424))]"" D
  1.  ;.S ABSP("RX",MEDN,"DIAG",0,491)=1
  1.  ;.S ABSP("RX",MEDN,"DIAG",1,492)=ABSP("OVERRIDE","RX",MEDN,492)
  1.  ;.S ABSP("RX",MEDN,"DIAG",1,424)=ABSP("OVERRIDE","RX",MEDN,424)
  1.  ;
  1.  S ABSP("RX",MEDN,"# Refills")=$P($G(^PSRX(RXIEN,0)),U,9)
  1.  S ABSP("RX",MEDN,"Refill #")=$$RXRFN(RXIEN,RXRFIEN)
  1.  S ABSP("RX",MEDN,"Prescriber IEN")=+PROVIEN
  1.  S ABSP("RX",MEDN,"Prescriber DEA #")=$P($G(^VA(200,+PROVIEN,"PS")),U,2)
  1.  S ABSP("RX",MEDN,"Prescriber CAID #")=$P($G(^VA(200,+PROVIEN,9999999)),U,7)
  1.  S ABSP("RX",MEDN,"Prescriber UPIN #")=$P($G(^VA(200,+PROVIEN,9999999)),U,8) ;*1.26*2*
  1.  S ABSP("RX",MEDN,"Prescriber State/Prov")=$P($G(^VA(200,+PROVIEN,.11)),U,5) ;Patch 42
  1.  ;
  1.  ;IHS/OIT/CASSEVERN/RAN 11/16/2010 PATCH 40 Adding Triplicate Serial # for New York Medicaid
  1.  S ABSP("RX",MEDN,"Triplicate Serial #")=$P($G(^PSRX(RXIEN,9999999)),U,14)
  1.  ;
  1.  ;Get Prescriber NPI #
  1.  S ABSP("RX",MEDN,"Prescriber NPI #")=$P($$NPI^XUSNPI("Individual_ID",+PROVIEN),U)
  1.  ;
  1.  S ABSP("RX",MEDN,"Prescriber Billing Location")=$S(PROVIEN]"":$P($G(^VA(200,PROVIEN,9999999)),"^",11),1:"") ; ANMC only?  not in Sitka's data dic.
  1.  ;IHS/SD/lwj 5/24/05 patch 12 nxt ln OK Medicaid pres last name
  1.  S ABSP("RX",MEDN,"Prescriber Last Name")=$P($P($G(^VA(200,+PROVIEN,0)),U),",")
  1.  ;
  1.  ;IHS/SD/lwj 6/1/05 patch 12 nxt ln WA L & I unique prov number
  1.  S ABSP("RX",MEDN,"Payer Assigned Prov #")=$$GET1^DIQ(200.9999918,ABSP("Insurer","IEN")_","_+PROVIEN_",",.02,"I")
  1.  ;
  1.  ;
  1.  D
  1.  . N %
  1.  . I PINSTYPE="CAID" D
  1.  . . S %=ABSP("RX",MEDN,"Prescriber CAID #")
  1.  . . I %="" D  ; special for ANMC
  1.  . . . N %1 S %1=ABSP("RX",MEDN,"Prescriber Billing Location")
  1.  . . . S %=$S(%1=1665:"MDG275",%1=1946:"MDG867",1:"")
  1.  . . I %="" S %=ABSP("Site","Default CAID #")
  1.  . E  D
  1.  . . S %=ABSP("RX",MEDN,"Prescriber DEA #")
  1.  . . I %="" S %=ABSP("Site","Default DEA #")
  1.  . S ABSP("RX",MEDN,"Prescriber ID")=%
  1.  ;
  1.  ;Set fields 466 and 411
  1.  S ABSP("Prescriber",MEDN,"Prescriber ID Qual")=12      ;default for 466
  1.  ;I ABSP("Send NPI")=1&(ABSP("RX",MEDN,"Prescriber NPI #")>0) D
  1.  I ABSP("Send Prescriber NPI")=1&(ABSP("RX",MEDN,"Prescriber NPI #")>0) D
  1.  . S ABSP("Prescriber",MEDN,"Prescriber ID Qual")="01"
  1.  . S ABSP("RX",MEDN,"Prescriber ID")=ABSP("RX",MEDN,"Prescriber NPI #")
  1.  ;
  1.  D:DRUGIEN'=""
  1.  .S ABSP("RX",MEDN,"Drug IEN")=DRUGIEN
  1.  .S ABSP("RX",MEDN,"Drug Name")=$P($G(^PSDRUG(DRUGIEN,0)),U,1)
  1.  .I ABSP("RX",MEDN,"NDC")="" D
  1.  ..S ABSP("RX",MEDN,"NDC")=$P($G(^PSDRUG(DRUGIEN,2)),U,4)
  1.  .;IHS/SD/RLT - 7/18/06 - Patch 18 - Add Unit of Measure
  1.  .S UOM=$P($G(^PSDRUG(DRUGIEN,660)),U,8)
  1.  .S ABSP("Claim",MEDN,"Unit of Measure")="EA"        ;default
  1.  .S:UOM="ML"!(UOM="ml")!(UOM="MILLILITERS") ABSP("Claim",MEDN,"Unit of Measure")="ML"
  1.  .S:UOM="GM"!(UOM="gm")!(UOM="GRAM") ABSP("Claim",MEDN,"Unit of Measure")="GM"
  1.  N PRICING S PRICING=^ABSPT(IEN59,5)
  1.  S ABSP("RX",MEDN,"Quantity")=$P(PRICING,U) ; 01/31/2001
  1.  S ABSP("RX",MEDN,"Unit Price")=$P(PRICING,U,2)
  1.  S ABSP("RX",MEDN,"Ingredient Cost")=$J($P(PRICING,U,3),0,2)
  1.  S ABSP("RX",MEDN,"Dispensing Fee")=$J($P(PRICING,U,4),0,2)
  1.  ;IHS/OIT/SCR 11/20/08 - add incentive fee information
  1.  S ABSP("RX",MEDN,"Incentive Amount")=$J($P(PRICING,U,7),0,2)
  1.  S ABSP("Site","Dispensing Fee")=ABSP("RX",MEDN,"Dispensing Fee")
  1.  S ABSP("RX",MEDN,"Gross Amount Due")=$J($P(PRICING,U,5),0,2)
  1.  S ABSP("RX",MEDN,"Usual & Customary")=$J($P(PRICING,U,5),0,2)
  1.  S ABSP("RX",MEDN,"Basis of Cost Determination")="00"     ;***RLT 12/19/06
  1.  I ABSP("NCPDP","Add Disp. Fee to Ingr. Cost") D
  1.  . N X S X=ABSP("RX",MEDN,"Ingredient Cost")
  1.  . S X=X+ABSP("RX",MEDN,"Dispensing Fee")
  1.  . S ABSP("RX",MEDN,"Ingredient Cost")=X
  1.  ;
  1.  ; Visit-related data
  1.  ;
  1.  I IEN59 D
  1.  . N VSITIEN S VSITIEN=$P(^ABSPT(IEN59,0),U,7)
  1.  . Q:'VSITIEN
  1.  . S ABSP("RX",MEDN,"Diagnosis Code")=$TR($$PRIMPOV^APCLV(VSITIEN,"C"),".","")
  1.  Q
  1.  ;
  1.  ; $$RXRFN()
  1.  ;Determine RX Refill Number based on prescription record
  1.  ;  It's overly cautious about making sure that the refills are
  1.  ;  counted in date filled order.
  1.  ;
  1.  ;Input Variables:    RXIEN    -  Prescription record IEN (52)
  1.  ;                    RXRFIEN  -  Refill multiple IEN
  1.  ;
  1.  ;Function Returns:   Null  - Could not process request
  1.  ;                    0     - Not a refill
  1.  ;                    N     - Refill number
  1.  ; Copied into here from ABSPECD4 so we can remove ABSPECD4 from kit.
  1.  ; Also called from ABSPOSN3
  1.  ;----------------------------------------------------------------------
  1. RXRFN(RXIEN,RXRFIEN) ;EP
  1.  ;Manage local variables
  1.  N COUNT,DATE,XIEN,STOP
  1.  ;
  1.  ;Make sure input variables are defined
  1.  Q:$G(RXIEN)="" ""
  1.  Q:$G(RXRFIEN)="" ""
  1.  ;
  1.  ;Initialize local variables
  1.  S (COUNT,STOP)=0
  1.  ;
  1.  ;Loop through refill multiple by date
  1.  S DATE=""
  1.  F  D  Q:'+DATE!(STOP)
  1.  .S DATE=$O(^PSRX(RXIEN,1,"B",DATE))
  1.  .Q:'+DATE
  1.  .;
  1.  .;For each sub-record increment refill count
  1.  .S XIEN=""
  1.  .F  D  Q:'+XIEN!(STOP)
  1.  ..S XIEN=$O(^PSRX(RXIEN,1,"B",DATE,XIEN))
  1.  ..Q:'+XIEN
  1.  ..S COUNT=COUNT+1
  1.  ..;
  1.  ..;STOP when you reach the refill record
  1.  ..S:XIEN=RXRFIEN STOP=1
  1.  Q $S(STOP=1:COUNT,1:0)
  1.  ;
  1.  ; Retrieve OVERRIDE nodes and put into ABSP array
  1.  ; They will be fetched from ABSP("OVERRIDE"
  1.  ; during low-level construction of the actual encoded claim packet.
  1.  ;
  1. OVERRIDE(IEN59,MEDN)    ; set any ABSP("OVERRIDE" nodes from 9002313.511 data
  1.  ; ABSP("OVERRIDE",field)=value  for fields 101-401
  1.  ; ABSP("OVERRIDE","RX",MEDN,field) for med #N, fields 402+
  1.  ; Note that if you have multiple prescriptions bundled, the
  1.  ; union of overrides from 101-401 apply to all; and if there's a 
  1.  ; conflict, the last one overwrites the previous ones.
  1.  N IEN511 S IEN511=$P(^ABSPT(IEN59,1),U,13) Q:'IEN511
  1.  D GET511^ABSPOSO2(IEN511,"ABSP(""OVERRIDE"")","ABSP(""OVERRIDE"",""RX"","_MEDN_")")
  1. CC Q
  1.  ;
  1. DURVALUE(IEN59,MEDN)         ;IHS/SD/lwj 8/20/02 NCPDP 5.1 changes
  1.  ; This subroutine will see if there is a DUR/PPS pointer for this
  1.  ; prescription - if there is, we will read through the DUR/PPS 
  1.  ; file and retrieve the values into the ABSP("RX",MEDN,DUR,....)
  1.  ; fields
  1.  ; (NOTE - unlike most values, these fields are stored by their
  1.  ; field number.  Since they are repeating, it will ease the 
  1.  ; retrieval of them, when we populate the claim.)
  1.  ;
  1.  N IEN473,DUR,DCNT,DURREC
  1.  ;
  1.  S IEN473=$P(^ABSPT(IEN59,1),U,14) Q:'IEN473   ;pointer to DUR/PPS fl
  1.  ;
  1.  S (DUR,DCNT)=0
  1.  F  S DCNT=$O(^ABSP(9002313.473,IEN473,1,DCNT)) Q:'+DCNT  D
  1.  . S DURREC=$G(^ABSP(9002313.473,IEN473,1,DCNT,0))
  1.  . S DUR=DUR+1
  1.  . S ABSP("RX",MEDN,"DUR",DUR,473)=DUR  ;dur/pps cntr
  1.  . S ABSP("RX",MEDN,"DUR",DUR,439)=$P(DURREC,U,2) ;Reason Srv Cd
  1.  . S ABSP("RX",MEDN,"DUR",DUR,440)=$P(DURREC,U,3) ;Prof Srv Cd
  1.  . S ABSP("RX",MEDN,"DUR",DUR,441)=$P(DURREC,U,4) ;Result Src Cd
  1.  . S ABSP("RX",MEDN,"DUR",DUR,474)=$P(DURREC,U,5) ;Level of Effort
  1.  . S ABSP("RX",MEDN,"DUR",DUR,475)=$P(DURREC,U,6) ;Co-agent Qual
  1.  . S ABSP("RX",MEDN,"DUR",DUR,476)=$P(DURREC,U,7) ;Co-agent ID
  1.  ;
  1.  Q
  1. DIAGVAL(IEN59,MEDN)         ;Diagnosis Code
  1.  ; Get data from Diagnosis Code file and put in ABSP array.
  1.  N IEN491,DIAG,DIAGCNT,DIAGREC
  1.  ;
  1.  S IEN491=$P(^ABSPT(IEN59,1),U,17) Q:'IEN491   ;pointer
  1.  ;
  1.  S ABSP("RX",MEDN,"DIAG",0,491)=$P($G(^ABSP(9002313.491,IEN491,0)),U,5)     ;diag code cnt
  1.  ;
  1.  S (DIAG,DIAGCNT)=0
  1.  F  S DIAGCNT=$O(^ABSP(9002313.491,IEN491,1,DIAGCNT)) Q:'+DIAGCNT  D
  1.  . S DIAGREC=$G(^ABSP(9002313.491,IEN491,1,DIAGCNT,0))
  1.  . Q:DIAGREC=""
  1.  . S DIAG=DIAG+1
  1.  . S ABSP("RX",MEDN,"DIAG",DIAG,492)=$P(DIAGREC,U,2) ;diag code qualifier
  1.  . S ABSP("RX",MEDN,"DIAG",DIAG,424)=$P(DIAGREC,U,3) ;diagnosis code
  1.  Q