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

ABSPOSCG.m

Go to the documentation of this file.
  1. ABSPOSCG ; IHS/SD/RLT - Set up ABSP() - CONT; [ 05/22/2006 9:00 AM ]
  1. ;;1.0;PHARMACY POINT OF SALE;**17,20,21,22,42,50**;MAY 22, 2006;Build 38
  1. ;---
  1. ;IHS/SD/RLT - 05/22/06 - Patch 17
  1. ; Created new routine ABSPOSCC getting too large.
  1. ; Added new code to access RR D elig data.
  1. ;---
  1. ;IHS/SD/RLT - 03/26/07 - Patch 20
  1. ; Added the following tags called from ABSPOSCC:
  1. ; GETMDPOL
  1. ; GETMDIEN
  1. ;---
  1. ;IHS/SD/RLT - 05/10/07 - Patch 21
  1. ; Added new tags MDFLG and RRDFLG.
  1. ;---
  1. ;IHS/SD/RLT - 05/22/07 - Patch 21
  1. ; Added new tag PHARNPI.
  1. ;---
  1. ;IHS/SD/RLT - 07/25/07 - Patch 22
  1. ; Fixed typo in tag RRDOB.
  1. Q
  1. ;
  1. GETRRDPL() ;EP ^ABSPOSCC
  1. N POL,RRDPOL S (POL,RRDPOL)=""
  1. ; /IHS/OIT/RAM ; 15 DEC 2017 ; Total rewrite to account for Medicare Bendficiary Identifier, or MBI.
  1. ; Does the individual have a new MBI? If so, get it and return.... Do we care? This isn't date specific, so everything is 'Today'...
  1. ; RRDFLAG has already been called and correct flags set -
  1. S:RRDFLG&(RRDIEN) RRDPOL=$P($G(^AUPNRRE(PINSDA,11,RRDIEN,0)),U,6)
  1. ; If the retrieve was successful, let's return that policy #.
  1. I RRDPOL'="" Q RRDPOL
  1. ; If not, let's see if Patient Reg has an updated 'old style' Railroad Elig. number
  1. S POL=$$GETRRE^AGUTL(PINSDA)
  1. ; if so, let's default to that & return.
  1. I POL'="" Q POL
  1. ; OK... the "new way" resulted in nothing. Let's fall back to the original code as a 'Plan B.'
  1. S POL=$P($G(^AUPNRRE(PINSDA,0)),U,4) ;orig
  1. ;
  1. Q POL
  1. ;
  1. RRNAME() ;EP ^ABSPOSCC
  1. N NAME,RRDNAME
  1. S NAME=$P($G(^AUPNRRE(PINSDA,21)),U) ;orig
  1. S RRDNAME=""
  1. S:RRDFLG&(RRDIEN) RRDNAME=$P($G(^AUPNRRE(PINSDA,11,RRDIEN,0)),U,5) ;RR D
  1. S:RRDNAME'="" NAME=RRDNAME
  1. Q NAME
  1. ;
  1. RRDOB() ;EP ^ABSPOSCC
  1. N DOB,RRDDOB
  1. S DOB=$P($G(^AUPNRRE(PINSDA,21)),U,2) ;orig
  1. S RRDDOB=""
  1. ;S:RREFLG&(RRDIEN) RRDDOB=$P($G(^AUPNRRE(PINSDA,11,RRDIEN,0)),U,9) ;RR D
  1. S:RRDFLG&(RRDIEN) RRDDOB=$P($G(^AUPNRRE(PINSDA,11,RRDIEN,0)),U,9) ;RR D
  1. S:RRDDOB'="" DOB=RRDDOB
  1. Q DOB
  1. ;
  1. RRDFLG() ;EP ^ABSPOSCC
  1. N FMTIEN,RRDFLG
  1. ;IHS/OIT/CASSEVER/RAN 03/24/2011 patch 42 Get rid of references to formats for new method of claims processing
  1. I $G(^ABSP(9002313.99,1,"ABSPICNV"))=1 D
  1. . S RRDFLG=$$GET1^DIQ(9002313.4,INSIEN_",",100.18,"I")
  1. ELSE D
  1. . S FMTIEN=$P($G(^ABSPEI(INSIEN,100)),U)
  1. . S RRDFLG=$P($G(^ABSPF(9002313.92,FMTIEN,1)),U,11)
  1. Q RRDFLG
  1. ;
  1. GETRRD() ;EP ^ABSPOSCC
  1. ;Get IEN for Railroad D elig record lookup.
  1. ;Railroad D eligibiiltiy lookup.
  1. ;N RRDFND,D1
  1. ;S RRDFND=""
  1. ;S D1="A"
  1. ;F S D1=$O(^AUPNRRE(PINSDA,11,D1),-1) Q:'D1!(RRDFND) D
  1. ;. Q:$P($G(^AUPNRRE(PINSDA,11,D1,0)),U,3)'="D" ;coverage type
  1. ;. S RRDFND=1
  1. ;. S RRDIEN=D1
  1. ;Q:'RRDFND ""
  1. ;Q RRDIEN
  1. Q ""
  1. ;
  1. OLDGETMDPOL() ;EP ^ABSPOSCC
  1. ;Updated policy number lookup for Medicare D elig.
  1. N POL,MDPOL
  1. S POL=$P($G(^AUPNMCR(PINSDA,0)),U,3) ;original
  1. S MDPOL=""
  1. ;S:MDIEN'="" MDPOL=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,6)
  1. S:MDFLG&(MDIEN) MDPOL=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,6)
  1. S:MDPOL'="" POL=MDPOL ;MPD
  1. Q POL
  1. ;
  1. GETMDPOL() ;EP Called from ^ABSPOSCC
  1. ; /IHS/OIT/RAM ; 15 DEC 2017 ; Total rewrite to account for Medicare Bendficiary Identifier, or MBI.
  1. ; /IHS/OIT/RAM ; 21 MAR 18 ; update to # logic - scan for Medicare Part D first, return that from the original area if it exists.
  1. ; Does the individual have a new MBI? If so, get it and return.... Do we care? This isn't date specific, so everything is 'Today'... just get the info...
  1. N POL,MDPOL S (POL,MDPOL)=""
  1. ; MDFLAG has already been called and correct flags set - let's use them to see if it's Medicare Part D & retrieve.
  1. S:MDFLG&(MDIEN) MDPOL=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,6)
  1. ; If the retrieve was successful, let's return that policy #.
  1. I MDPOL'="" Q MDPOL
  1. ; If not, then let's go snag the individual's MBI if it exists...
  1. S POL=$$GETMCR^AGUTL(PINSDA)
  1. ; if MBI exists, let's default to that & return.
  1. I POL'="" Q POL
  1. ; OK... the "new way" & Medicare D resulted in nothing. Let's fall back to the original code as a 'Plan B.'
  1. S POL=$P($G(^AUPNMCR(PINSDA,0)),U,3) ;original
  1. ;
  1. Q POL
  1. ;
  1. MDFLG() ;EP ^ABSPOSCC
  1. N FMTIEN,MDFLG
  1. ;IHS/OIT/CASSEVER/RAN 03/24/2011 patch 42 Get rid of references to formats for new method of claims processing START
  1. I $G(^ABSP(9002313.99,1,"ABSPICNV"))=1 D
  1. . S MDFLG=$$GET1^DIQ(9002313.4,INSIEN_",",100.18,"I")
  1. ELSE D
  1. . S FMTIEN=$P($G(^ABSPEI(INSIEN,100)),U)
  1. . S MDFLG=$P($G(^ABSPF(9002313.92,FMTIEN,1)),U,11)
  1. Q MDFLG
  1. ;
  1. GETMDIEN() ;EP ^ABSPOSCC
  1. ;Get IEN for Medicare D elig record lookup.
  1. ;New Medicare D eligibiiltiy lookup.
  1. ;N MDFND,D1
  1. ;S MDFND=""
  1. ;S D1="A"
  1. ;F S D1=$O(^AUPNMCR(PINSDA,11,D1),-1) Q:'D1!(MDFND) D
  1. ;. Q:$P($G(^AUPNMCR(PINSDA,11,D1,0)),U,3)'="D" ;coverage type
  1. ;. S MDFND=1
  1. ;. S MDIEN=D1
  1. ;Q:'MDFND ""
  1. ;Q MDIEN
  1. Q ""
  1. ;
  1. PHARNPI(X,Y) ;EP
  1. ;FILE #9002313.56 - ABSP PHARMACIES FILE
  1. ;MULTIPLE 13800 - OUTPATIENT SITE
  1. ;COMPUTED Field .02 - PHARMACY NPI #
  1. Q:$G(X)="" ""
  1. Q:$G(Y)="" ""
  1. N OPSITE,INST,NPI
  1. S OPSITE=$P($G(^ABSP(9002313.56,X,"OPSITE",Y,0)),U)
  1. Q:OPSITE="" ""
  1. S INST=$P($G(^PS(59,OPSITE,"INI")),U,2)
  1. Q:INST="" ""
  1. S NPI=$P($$NPI^XUSNPI("Organization_ID",INST),U)
  1. Q NPI
  1. ;