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