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

ABSPOSSG.m

Go to the documentation of this file. 
  1. ABSPOSSG ; IHS/SD/lwj - Special gets for formats ;      [ 12/23/2002  8:10 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**1,2,3,4,5,42**;JUN 21, 2001;Build 38
  1.  ;----------------------------------------------------------------------
  1.  ; IHS/SD/lwj 07/31/02
  1.  ; If version 3.2 there were several fields that were defined - when
  1.  ; 5.1 came along, the fields had to be duplicated because of repeating
  1.  ; values - as such, new logic was added into this program to 
  1.  ; set the fields ^ABSPC entry based on the claim version used.
  1.  ;
  1.  ; FMT416 is now obsolete - remove with next patch or release
  1.  ;----------------------------------------------------------------------
  1.  ;IHS/SD/lwj 10/28/02 - added code for Idaho medicaid state license #
  1.  ;
  1.  ;IHS/SD/lwj 11/29/02 - fixed made to the STATE subroutine to referenece
  1.  ; ABSP(9002313.0201 instead of typo ABSP(9002313.02
  1.  ; (error reported by Tawaoc and Ignacio)
  1.  ;
  1.  ;IHS/SD/lwj 12/12/02 - fix made for loading of duel fields (i.e. fields
  1.  ; stored in the 3.2 header and 5.1 detail)  
  1.  ; 
  1.  Q
  1.  ;*******************************************************************
  1.  ;  IHS/SD/lwj  10/28/02
  1.  ;  The COLSTATE routine is now OBSOLETE - it can be removed in
  1.  ;  any patch following Patch 3 of V1.0 of POS
  1. COLSTATE()          ;EP  entry point frm clm frmt for Colorado State Lic
  1.  ; This entry point is only called from within a claim format
  1.  ; that requires the retrieval of the Colorado State License
  1.  ; number.
  1.  ;
  1.  N ABSPST,ABSPFND,ABSPLIC,ABSPPRO  ;state IEN, fnd ind, state lic 
  1.  S (ABSPST,ABSPFND,ABSPLIC,ABSPPRO)=""
  1.  ;
  1.  ; Retrieve the IEN for file 200 
  1.  ; Retrieve provider IEN into file 16 from 200
  1.  ; Loop through file 16 State licenses until we locate a Colorado
  1.  ; state license.
  1.  ; If Colorado state license not found - return the default Medicaid
  1.  ; number - this will fail the claim, but alert them to a missing
  1.  ; state license number.
  1.  ;
  1.  S ABSPPRO=$G(ABSP("RX",ABSP(9002313.0201),"Prescriber IEN")) ;for 200
  1.  I ABSPPRO S ABSPPRO=$P($G(^VA(200,ABSPPRO,0)),U,16)  ;get prov
  1.  ;
  1.  I ABSPPRO'="" D
  1.  . F  S ABSPST=$O(^DIC(6,ABSPPRO,999999921,ABSPST)) Q:ABSPST=""  D
  1.  .. I $P($G(^DIC(5,ABSPST,0)),U)["COLORADO" D
  1.  ... S ABSPLIC=$P($G(^DIC(6,ABSPPRO,999999921,ABSPST,0)),U,2)
  1.  ... S ABSPFND=1
  1.  ... S ABSPST=99999999
  1.  ;
  1.  I 'ABSPFND S ABSPLIC=ABSP("Site","Default CAID #")
  1.  ;
  1.  Q ABSPLIC
  1.  ;
  1.  ;*******************************************************************
  1. STATE(STATE) ;EP IHS/SD/lwj 10/28/02 retrieve the state license number
  1.  ; This code will replace the COLSTATE code.
  1.  ; Incoming - the two character state abbreviation for the state
  1.  ;            license we need
  1.  ; Outgoing - the licence number if found, or the default Medicaid #
  1.  ;
  1.  N STPOINT,DRPOINT,LIPOINT,LICENSE
  1.  S (STPOINT,DRPOINT,LIPOINT,LICENSE)=""
  1.  S STPOINT=$O(^DIC(5,"C",STATE,0))   ;state pointer
  1.  ;
  1.  ;IHS/SD/lwj 11/29/02 next line remarked out, following line added
  1.  ;S DRPOINT=$G(ABSP("RX",ABSP(9002313.02),"Prescriber IEN")) ;prsc pntr
  1.  S DRPOINT=$G(ABSP("RX",ABSP(9002313.0201),"Prescriber IEN")) ;prsc pntr
  1.  ;
  1.  ; get the license pointer
  1.  S:STPOINT&DRPOINT LIPOINT=$O(^VA(200,DRPOINT,"PS1","B",STPOINT,0))
  1.  S:LIPOINT LICENSE=$P($G(^VA(200,DRPOINT,"PS1",LIPOINT,0)),U,2)
  1.  ;
  1.  S:LICENSE="" LICENSE=$G(ABSP("Site","Default CAID #"))
  1.  ;
  1.  Q LICENSE
  1.  ;
  1. NEW416() ; IHS/SD/lwj 8/30/02   NCPDP 5.1
  1.  ; Field 416 is obsolete in version 5.1 - BUT - the logic that
  1.  ; is used in 5.1 is similiar for populating 3.2 claims that
  1.  ; use field 416.  So - we will use this routine only until
  1.  ; 3.2 is obsolete.
  1.  ;
  1.  N PATYPE,PANUM,PA
  1.  ;
  1.  S PATYPE=$E($G(ABSP("X")),1,1)
  1.  S PANUM=$E($G(ABSP("X")),2,12)
  1.  S PA="DG"_$G(PATYPE)_$$NFF^ABSPECFM($G(PANUM),11)
  1.  ;
  1.  Q PA
  1. FMT416() ;----------------------------------------------------------------
  1.  ;| *** OBSOLETE  ***  OBSOLETE  ***  OBSOLETE ***  OBSOLETE     |
  1.  ;|  With the addition of the 5.1 fields, this routine is no     |
  1.  ;|  longer needed or used.  We will keep in around only until   |
  1.  ;|  the next full release of Pharmacy Point of Sale             |
  1.  ;----------------------------------------------------------------
  1.  ;
  1.  N ABSPPA,ABSPCD,ABSPPC
  1.  ;
  1.  ; IHS/SD/lwj 6/19/02 chged to add 4 exemption from copay
  1.  ;  S ABSPCD=$S(ABSP("X")=5:5,1:$S(ABSP("X"):"1",1:"0"))
  1.  ;  S ABSPCD=$S(ABSP("X")=2:2,ABSP("X")=5:5,1:$S(ABSP("X"):"1",1:"0"))
  1.  S ABSPCD=$S(ABSP("X")=2:2,ABSP("X")=4:4,ABSP("X")=5:5,1:$S(ABSP("X"):"1",1:"0"))
  1.  ;
  1.  ; IHS/SD/lwj 6/19/02 chged to add 4 exemption from copay
  1.  ;  I ABSP("X")=5 D      ;exemptions from prescription limits
  1.  ;  I (ABSP("X")=5)!(ABSP("X")=2) D   ;exempt frm pres lmts/med cert
  1.  I (ABSP("X")=5)!(ABSP("X")=2)!(ABSP("X")=4) D   ;prs lmt/med cert/cpy
  1.  . S ABSPPA=$$NFF^ABSPECFM("",11)
  1.  ;
  1.  ; IHS/SD/lwj 6/19/02 chged to add 4 exemption from copay
  1.  ;I ABSP("X")'=5 D     ;prior authorization
  1.  ;I (ABSP("X")'=5)&(ABSP("X")'=2) D     ;prior authorization
  1.  I (ABSP("X")'=5)&(ABSP("X")'=2)&(ABSP("X")'=4) D  ;prior authorization
  1.  . S ABSPPA=$$NFF^ABSPECFM($G(ABSP("X")),11)
  1.  ;
  1.  S ABSPPC="DG"_ABSPCD_ABSPPA
  1.  ;
  1.  Q ABSPPC
  1.  ;
  1.  ;-------------------------------------------------------------------
  1.  ; All of the following fields were placed in here as part of the 
  1.  ; restructuring involved in NCPDP 5.1.
  1.  ; For fields 308, 315, 316, 317, 318, 319, 320, and 327 the set
  1.  ; code for 3.2 will remain exactly as it was - for 5.1 we will
  1.  ; update the "newer" location for those fields as well.
  1.  ;-------------------------------------------------------------------
  1. FLD308 ;Other Coverage Code 
  1.  ; 3.2/5.1 Set code - called by set command in ABSP NCPDP Field Defs
  1.  ;
  1.  ; 3.2 SET
  1.  S $P(^ABSPC(ABSP(9002313.02),300),U,8)=ABSP("X")
  1.  ;
  1.  ; 5.1 Set
  1.  ;IHS/SD/lwj 12/20/02  nxt line remarked out, following line added
  1.  ;I $D(ABSP(9002313.0201)) D
  1.  I $G(ABSP(9002313.0201))'="" D
  1.  . S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),300),U,8)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD315 ;Employer Name  
  1.  ; 3.2/5.1 Set Code - called by set command in ABSP NCPDP Field Defs
  1.  ;
  1.  ; 3.2 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),300),U,15)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  ;IHS/SD/lwj 12/20/02  nxt line remarked out, following line added
  1.  ;I $D(ABSP(9002313.0201)) D
  1.  I $G(ABSP(9002313.0201))'="" D
  1.  . S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),310),U,5)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD316 ;Employer Street Address
  1.  ; 3.2/5.1 Set Code - called by set command in ABSP NCPDP Field DEfs
  1.  ;
  1.  ;3.2 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),300),U,16)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  ;IHS/SD/lwj 12/20/02  nxt line remarked out, following line added
  1.  ;I $D(ABSP(9002313.0201)) D
  1.  I $G(ABSP(9002313.0201))'="" D
  1.  . S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),310),U,6)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD317 ;Employer City Address  
  1.  ;3.2/5.1 Set Code - called by set command in ABSP NCPDP Field Defs
  1.  ;
  1.  ;3.2 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),300),U,17)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  ;IHS/SD/lwj 12/20/02  nxt line remarked out, following line added
  1.  ;I $D(ABSP(9002313.0201)) D
  1.  I $G(ABSP(9002313.0201))'="" D
  1.  . S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),310),U,7)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD318 ;Employer State/Prov Address
  1.  ;3.2/5.1 Set Code - called by set command in ABSP NCPDP Field Defs
  1.  ;
  1.  ;3.2 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),300),U,18)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  ;IHS/SD/lwj 12/20/02  nxt line remarked out, following line added
  1.  ;I $D(ABSP(9002313.0201)) D
  1.  I $G(ABSP(9002313.0201))'="" D
  1.  . S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),310),U,8)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD319 ;Employer Zip/Postal Zip
  1.  ;3.2/5.1 Set Code - called by set command in ABSP NCPDP Field Defs
  1.  ;
  1.  ;3.2 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),300),U,19)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  ;IHS/SD/lwj 12/20/02  nxt line remarked out, following line added
  1.  ;I $D(ABSP(9002313.0201)) D
  1.  I $G(ABSP(9002313.0201))'="" D
  1.  . S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),310),U,9)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD320 ;Employer Phone Number
  1.  ;3.2/5.1 Set Code - called by set command in ABSP NCPDP Field Defs
  1.  ;
  1.  ;3.2 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),320),U,20)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  ;IHS/SD/lwj 12/20/02  nxt line remarked out, following line added
  1.  ;I $D(ABSP(9002313.0201)) D
  1.  I $G(ABSP(9002313.0201))'="" D
  1.  . S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),310),U,10)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD327 ;Carrier ID
  1.  ;3.2/5.1 Set Code - called by set command in ABSP NCPDP Field Defs
  1.  ;
  1.  ;3.2 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),320),U,27)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  ;IHS/SD/lwj 12/20/02  nxt line remarked out, following line added
  1.  ;I $D(ABSP(9002313.0201)) D
  1.  I $G(ABSP(9002313.0201))'="" D
  1.  . S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),320),U,7)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1.  ;----------------------------------------------------------------
  1.  ;For subroutines FLD439, FLD440, FLD441:
  1.  ; These field were single entry fields in 3.2, but are now
  1.  ; a part of the NCPDP 5.1 DUR/PPS repeating segment.  The
  1.  ; calls to these subroutines are initiated by their respective
  1.  ; fields in the set logic of the ABSP NCPDP Field Def entry.
  1.  ; ABSP51 and DUR will be set in ABSPOSHF subroutine DURPPS
  1.  ;----------------------------------------------------------------
  1. FLD439 ;Reason for service code
  1.  ;IHS/OIT/CASSEVERN/PIERAN/RAN 4/22/2011 patch 42 3.2 NO LONGER USED ABSP51 flag not needed.
  1.  ;3.2 Set
  1.  ;I '$G(ABSP51) S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),430),U,9)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,DUR,0),U,2)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD440 ;Professional Service Code
  1.  ;IHS/OIT/CASSEVERN/PIERAN/RAN 4/22/2011 patch 42 3.2 NO LONGER USED ABSP51 flag not needed.
  1.  ;3.2 Set
  1.  ;I '$G(ABSP51) S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),430),U,10)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,DUR,0),U,3)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD441 ;Result of Service Code
  1.  ;IHS/OIT/CASSEVERN/PIERAN/RAN 4/22/2011 patch 42 3.2 NO LONGER USED ABSP51 flag not needed.
  1.  ;3.2 Set
  1.  ;I '$G(ABSP51) S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),440),U,1)=ABSP("X")
  1.  ;
  1.  ;5.1 Set
  1.  S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,DUR,0),U,4)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD473 ;DUR/PPS code counter - called from set logic in ABSP NCPDP Field Defs
  1.  ; repeating field on the DUR/PPS 5.1 segment - 
  1.  ; Since this is the .01 field - we also need to set the cross ref
  1.  ; here as well 
  1.  ;
  1.  S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,DUR,0),U,1)=ABSP("X")
  1.  S ^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,"B",ABSP("X"),DUR)=""
  1.  ;
  1.  Q
  1.  ;
  1.  ;------------------------------------------------------------------
  1.  ; Set logic for flds 474, 475 and 476 move to this routine to 
  1.  ; avoid the wrapping within the global which has been known to 
  1.  ; split when installed on certain systems.
  1.  ;------------------------------------------------------------------
  1. FLD474 ;DUR/PPS level of effort - called from set logic in ABSP NCPDP Field
  1.  ; Defs repeating field on the DUR/PPS 5.1 segment
  1.  ;
  1.  S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,DUR,0),U,5)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD475 ;DUR Co-agent ID Qualifier - called from set logic in ABSP NCPDP Field
  1.  ; Defs repeating field on the DUR/PPS 5.1 segment
  1.  ;
  1.  S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,DUR,0),U,6)=ABSP("X")
  1.  ;
  1.  Q
  1.  ;
  1. FLD476 ;DUR Co-agent ID - called from set logic in ABSP NCPDP Field
  1.  ; Defs repeating field on the DUR/PPS 5.1 segment
  1.  ;
  1.  S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,DUR,0),U,7)=ABSP("X")
  1.  ;
  1.  Q