- 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 ;