ABSPOSFC ; IHS/FCS/DRS - Set up ABSP() ; [ 09/12/2002 10:09 AM ]
;;1.0;PHARMACY POINT OF SALE;**3,15,16,40,50**;JUN 21, 2001;Build 38
;----------------------------------------------------------------------
;----------------------------------------------------------------------
Q
; This is a copy of routine ABSPOSCC, made on 03/20/2001.
; It has some minor changes for printing NCPDP forms.
; Try to keep the two versions in synch.
;
; Called by ABSPOSFB from ABSPOSFA.
; GETINFO gets the patient/visit-level stuff
;
;----------------------------------------------------------------------
;IHS/SD/RLT - 01/24/06 - Patch 15
; Added new code to access new Medicare D eligibility data.
;----------------------------------------------------------------------
;IHS/SD/RLT - 02/13/06 - Patch 16
; Added new code to access Group # in Medicare D eligibility data.
;----------------------------------------------------------------------
;
GETINFO(DIALOUT,PATIEN,VSTIEN,PINS,INSIEN) ;EP
N XDATA,NRECIEN
; PINSDA = pointer into insurance eligible file,
; PINSDA = pointer into multiple of ^AUPNPRVT where appropriate
N PINSDA,PINSDA1,PINSTYPE S PINSDA=$P(PINS,",",2),PINSTYPE=$P(PINS,",")
I PINSTYPE="PRVT" S PINSDA1=$P(PINS,",",3) ; else PINSDA1 undef
S ABSP("VisitIEN")=VSTIEN
;
;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
;New Medicare D eligibiiltiy lookup.
;Set IEN to be used in policy# and name lookup.
N MDIEN
S MDIEN=""
S:PINSTYPE="CARE" MDIEN=$$GETMDIEN
;IHS/SD/RLT - 01/24/06 - Patch 15 - end
;
;"Site" nodes
;S ABSP("Site","IEN")=DIALOUT
;S ABSP("Site","Switch Type")=$$SWTYPE(DIALOUT)
N PHARMACY
D
. N IEN57 S IEN57=$O(TRANSACT(""))
. S PHARMACY=$P(^ABSPTL(IEN57,1),U,7)
. S XDATA=^ABSP(9002313.56,PHARMACY,0)
. S ABSP("Site","NABP #")=$P(XDATA,U,2)
. S ABSP("Site","Default DEA #")=$P(XDATA,U,3)
. S ABSP("Envoy Terminal ID")=$P(XDATA,U,6)
. S ABSP("Site","Name")=$P(XDATA,U)_" PHARMACY"
. S ABSP("Site","Tax ID #")=$P(XDATA,U,5)
. S XDATA=$G(^ABSP(9002313.56,PHARMACY,"CAID"))
. S ABSP("Site","Medicaid Pharmacy #")=$P(XDATA,U)
. S ABSP("Site","Default CAID #")=$P(XDATA,U,2)
. S XDATA=$G(^ABSP(9002313.56,PHARMACY,"NDC"))
. S ABSP("Site","NDC ID")=$P(XDATA,U)
. ; These additional nodes for paper forms only:
. N ADDR S ADDR=$G(^ABSP(9002313.56,PHARMACY,"ADDR"))
. S ABSP("Site","Addr")=$P(ADDR,U) I $P(ADDR,U,2)]"" D
. . S ABSP("Site","Addr")=ABSP("Site","Addr")_"/"_$P(ADDR,U,2)
. S ABSP("Site","City")=$P(ADDR,U,3)
. S ABSP("Site","State")=$P(ADDR,U,4)
. S ABSP("Site","Zip")=$P(ADDR,U,5)
. S ABSP("Site","Phone")=$P(ADDR,U,6)
. S ABSP("Site","Fax")=$P(ADDR,U,7)
. S ABSP("Site","Contact")="" ; contact name
. ; May have special list of contact names and phone #s
. ; (the old NCPDP form had a line for Contact name as well as phone #)
. N X S X=$G(^ABSP(9002313.56,PHARMACY,"REP"))
. Q:$P(X,U,2)=""
. N N S N=$L($P(X,U,2),",") ; how many contact names/phone #s
. S N=$R(N)+1 ; pick one at random
. S ABSP("Site","Phone")=$P($P(X,U,2),",",N)
. S ABSP("Site","Contact")=$P($P(X,U),",",N)
;
S XDATA=^DPT(PATIEN,0)
S ABSP("Patient","IEN")=PATIEN
D ; Patient,Name
. N % I PINSTYPE="CAID" D
. . S %=$$CAIDNAME
. E I PINSTYPE="CARE" D
. . S %=$$CARENAME
. E S %=""
. I %="" S %=$P(XDATA,U)
. S ABSP("Patient","Name")=%
S ABSP("Patient","Sex")=$P(XDATA,U,2)
S ABSP("Patient","DOB")=$P(XDATA,U,3)
S ABSP("Patient","SSN")=$P(XDATA,U,9)
;
;"RX" mode containing date filled
; (All of the prescriptions are the same date filled
; because they're all for the same visit. We assume.)
;IHS/OIT/CNI/RAN Patch 40 This is not the correct date
;S ABSP("RX","Date Filled")=$P($G(^AUPNVSIT(VSTIEN,0)),U,1)
;
;"Insurer" nodes
S (INSIEN,ABSP("Insurer","IEN"))=INSIEN ;$$INSIEN
S ABSP("Cardholder","Last Name")=$$INSDNAME(2)
S ABSP("Cardholder","First Name")=$$INSDNAME(1)
S ABSP("Insurer","Relationship")=$$INSREL
S ABSP("Insurer","Person Code")=$$PERSON
;ABSP("Eligibility Clarification code")=$$ELGCLAR
S ABSP("Insurer","Group #")=$$INSGRP
S ABSP("Insurer","Policy #")=$$INSPOL
;IHS/OIT/SCR 01/15/09 patch 29
S ABSP("Insurer","Member #")=$$INSMBRNM
;
; Pharmacy number: usually NABP #, but sometimes the insurer demands
; their own insurer-assigned pharmacy number. Especially with Medicaid
S ABSP("Site","Pharmacy #")=ABSP("Site","NABP #")
I $D(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #","B",INSIEN)) D
. N X S X=$O(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #","B",INSIEN,0))
. S ABSP("Site","Pharmacy #")=$P(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,2)
; Anachronism: Medicaid Pharmacy # is a special field,
; properly, it belongs in the INSURER-ASSIGNED #
; But that Medicaid Pharmacy # will overwrite the in INS.-ASSIGNED #
I PINSTYPE="CAID",ABSP("Site","Medicaid Pharmacy #")]"" D
. S ABSP("Site","Pharmacy #")=ABSP("Site","Medicaid Pharmacy #")
;"NCPDP" nodes
S NRECIEN=$P($G(^ABSPEI(INSIEN,100)),U,1)
D ; most of this is electronic only but retained anyhow
.S ABSP("NCPDP","IEN")=NRECIEN
.I NRECIEN S XDATA=$G(^ABSPF(9002313.92,NRECIEN,1))
.E S XDATA="" ;
.S $P(XDATA,U,8)=0 ; do not add disp fee to ingr cost on paper forms
.S ABSP("NCPDP","BIN Number")=$P(XDATA,U,1)
.S ABSP("NCPDP","Version")=$P(XDATA,U,2)
.S ABSP("NCPDP","# Meds/Claim")=$P(XDATA,U,3)
.S ABSP("NCPDP","Envoy Plan Number")=$P(XDATA,U,4)
.I $P(XDATA,U,8)="" S $P(XDATA,U,8)=1
.S ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=$P(XDATA,U,8)
I $$WORKREL D ; extra info for workers comp claims
. D INSWORK
. S ABSP("Date of Injury")=$P(^AUPNVPOV($$WORKREL,0),U,8)
;IHS/OIT/SCR 01/15/09 - added 'SPECIAL' node info
;"SPECIAL" node
S ABSP("SPECIAL","SUBSCRIBER ID")=$P($G(^ABSP(9002313.99,1,"SPECIAL")),U,4)
Q
WORKREL() ; this is copied from ABSPOS26+/- ; changed ABSBVISI to VSTIEN
; is VSTIEN a worker's comp visit?
; If so, return value is true = pointer to ^AUPNVPOV which has
; the CAUSE OF DX listed as EMPLOYMENT RELATED
N A,RET S (A,RET)=0
F S A=$O(^AUPNVPOV("AD",VSTIEN,A)) Q:'A D Q:RET
. I $P($G(^AUPNVPOV(A,0)),U,7)=4 D
. . S RET=A
Q RET
; $$INSxxx functions - given PINSTYPE, PINSDA, PINSDA1
INSIEN() ; get pointer to ^AUTNINS
; (But shouldn't we directly get this from the IEN59?)
I PINSTYPE="CAID" Q $P($G(^AUPNMCD(PINSDA,0)),U,2)
I PINSTYPE="PRVT" Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U)
I PINSTYPE="CARE" Q $P($G(^AUPNMCR(PINSDA,0)),U,2)
I PINSTYPE="RR" Q $P($G(^AUPNRRE(PINSDA,0)),U,2)
I PINSTYPE="SELF" Q ""
D IMPOSS^ABSPOSUE("P","TI","bad PINSTYPE="_PINSTYPE,,"INSIEN",$T(+0))
Q ""
INSREL() ; a single digit, 1, 2, 3, 4 = self,spouse,child,other
N X S X=+$$AUTTRLSH Q:'X 4 ; X points to ^AUTTRLSH(
; Translate it using our own file, 9002313.81
S X=$P($G(^AUTTRLSH(X,0)),U) Q:X="" 4 ; translate to name
S X=$O(^ABSPF(9002313.81,"B",X,0)) Q:'X 4 ; point into 9002313.81
S X=$P(^ABSPF(9002313.81,X,0),U,2)
Q $S(X:X,1:4)
AUTTRLSH() ; relationship - pointer to ^AUTTRLSH
I PINSTYPE="PRVT" Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,5)
N X S X=$O(^AUTTRLSH("B","SELF",0)) I 'X D IMPOSS^ABSPOSUE("DB","TI","RELATIONSHIP file is missing SELF entry",,"AUTTRLSH",$T(+0))
ELGCLAR() ; Eligibility clarification code
; From Paid Presc. documentation:
; 3=Full-time student; 4=Disabled dependent; 5=Dependent parent
; 6=Significant other. Required if relationship code=3 or 4 and
; patient is age 18 or over.
Q ""
PERSON() ; Person Code
; For now, it's a simple translation from relationship code:
; 1->"01", 2->"02", etc.
Q "0"_$$INSREL
INSGRP() ; Insurer Group #
;RLT - 2/13/06 - Patch 16
;Get Medicare D group #
N GRPIEN
S GRPIEN=""
S:PINSTYPE="CARE"&(MDIEN) GRPIEN=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,11)
Q:GRPIEN $P($G(^AUTNEGRP(GRPIEN,0)),U,2)
;RLT - 2/13/06 - Patch 16
I PINSTYPE'="PRVT" Q ""
N X S X=$$INS3PPH Q:'X ""
N Y S Y=$P($G(^AUPN3PPH(X,0)),U,6) Q:'Y ""
N Z S Z=$P($G(^AUTNEGRP(Y,11,111,0)),U,2) ; OUTPATIENT group # if poss
I Z="" S Z=$P($G(^AUTNEGRP(Y,0)),U,2) ; else take the general one
Q Z
INSDNAME(N) ; Insured's name
N X
I PINSTYPE="CAID" S X=$$CAIDNAME
E I PINSTYPE="CARE" S X=$$CARENAME
E I PINSTYPE="SELF"!(PINSTYPE="RR") S X=ABSP("Patient","Name")
E I PINSTYPE="PRVT" D
. N T S T=$$INS3PPH
. I 'T S X="" Q ; no 3PPH?
. S X=$P(^AUPN3PPH(T,0),U) ; Policy holder
E D IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSDNAME",$T(+0))
I X="" S X=ABSP("Patient","Name")
I N=1 Q $P(X,",",2) ; first name
E I N=2 Q $P(X,",",1) ; last name
E Q X ; entire name
INSWORK ; get worker's comp-related info
Q:PINSTYPE'="PRVT"
N P S P=$$INS3PPH Q:'P
N X S X=$P($G(^AUPN3PPH(P,0)),U,16) Q:'X
S X=$G(^AUTNEMPL(X,0)) Q:X=""
S ABSP("Employer","Name")=$P(X,U)
S ABSP("Employer","Address")=$P(X,U,2)
S ABSP("Employer","City")=$P(X,U,3)
D
. N ST
. S ABSP("Employer","State")=$P(^DIC(5,ST,0),U,2)
S ABSP("Employer","Zip Code")=$P(X,U,5)
S ABSP("Employer","Phone")=$P(X,U,6)
Q
INS3PPH() Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,8)
INSPOL() ; /IHS/OIT/RAM ; 15 DEC 17 - IT APPEARS THAT THIS ROUTINE HAS NOT BEEN KEPT UP
; I WONDER IF IT'S EVEN IN USE...
I PINSTYPE="CAID" Q $P($G(^AUPNMCD(PINSDA,0)),U,3)
;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
;I PINSTYPE="CARE" Q $P($G(^AUPNMCR(PINSDA,0)),U,3) ; no suffix?
I PINSTYPE="CARE" Q $$GETMDPOL
;IHS/SD/RLT - 01/24/06 - Patch 15 - end
; I PINSTYPE="RR" Q $P($G(^AUPNRRE(PINSDA,0)),U,4) ; no prefix?
I PINSTYPE="RR" Q $$GETRRE^AGUTL(PINSDA) ; /IHS/OIT/RAM ; 18 DEC 17 - New method for retrieving the RR Policy Number.
I PINSTYPE="SELF" Q ""
I PINSTYPE'="PRVT" D IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSPOL",$T(+0))
N X S X=$$INS3PPH
I X N Y S Y=$P($G(^AUPN3PPH(X,0)),U,4) I Y]"" Q Y ; 3PPH version first
Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,2) ; else PRVT version
INSMBRNM() ; Member #
;IHS/OIT/SCR 01/15/09 - Patch 29
N ABSPMNUM
S ABSPMNUM=""
S:PINSTYPE="PRVT" ABSPMNUM=$G(^AUPNPRVT(PINSDA,11,PINSDA1,2))
Q ABSPMNUM
OLDGETMDPOL() ;Updated policy number lookup for Medicare D elig.
;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
N POL,MDPOL
S POL=$P($G(^AUPNMCR(PINSDA,0)),U,3) ;original Medicare policy#
S MDPOL=""
S:MDIEN'="" MDPOL=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,6)
S:MDPOL'="" POL=MDPOL ;use Medicare D policy# if elig found
Q POL
;IHS/SD/RLT - 01/24/06 - Patch 15 - end
GETMDPOL() ;EP ; /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
;
CAIDNAME() Q $P($G(^AUPNMCD(PINSDA,21)),U)
CARENAME() ;Q $P($G(^AUPNMCR(PINSDA,21)),U)
;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
;Updated name lookup for new Medicare D elig.
N NAME,MDNAME
S NAME=$P($G(^AUPNMCR(PINSDA,21)),U) ;original Medicare name
S MDNAME=""
S:MDIEN'="" MDNAME=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,5)
S NAME=MDNAME ;use Medicare D name if elig found
Q NAME
;IHS/SD/RLT - 01/24/06 - Patch 15 - end
GETMDIEN() ;Get IEN for Medicare D elig record lookup.
;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
;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
;IHS/SD/RLT - 01/24/06 - Patch 15 - end
ABSPOSFC ; IHS/FCS/DRS - Set up ABSP() ; [ 09/12/2002 10:09 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3,15,16,40,50**;JUN 21, 2001;Build 38
+2 ;----------------------------------------------------------------------
+3 ;----------------------------------------------------------------------
+4 QUIT
+5 ; This is a copy of routine ABSPOSCC, made on 03/20/2001.
+6 ; It has some minor changes for printing NCPDP forms.
+7 ; Try to keep the two versions in synch.
+8 ;
+9 ; Called by ABSPOSFB from ABSPOSFA.
+10 ; GETINFO gets the patient/visit-level stuff
+11 ;
+12 ;----------------------------------------------------------------------
+13 ;IHS/SD/RLT - 01/24/06 - Patch 15
+14 ; Added new code to access new Medicare D eligibility data.
+15 ;----------------------------------------------------------------------
+16 ;IHS/SD/RLT - 02/13/06 - Patch 16
+17 ; Added new code to access Group # in Medicare D eligibility data.
+18 ;----------------------------------------------------------------------
+19 ;
GETINFO(DIALOUT,PATIEN,VSTIEN,PINS,INSIEN) ;EP
+1 NEW XDATA,NRECIEN
+2 ; PINSDA = pointer into insurance eligible file,
+3 ; PINSDA = pointer into multiple of ^AUPNPRVT where appropriate
+4 NEW PINSDA,PINSDA1,PINSTYPE
SET PINSDA=$PIECE(PINS,",",2)
SET PINSTYPE=$PIECE(PINS,",")
+5 ; else PINSDA1 undef
IF PINSTYPE="PRVT"
SET PINSDA1=$PIECE(PINS,",",3)
+6 SET ABSP("VisitIEN")=VSTIEN
+7 ;
+8 ;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
+9 ;New Medicare D eligibiiltiy lookup.
+10 ;Set IEN to be used in policy# and name lookup.
+11 NEW MDIEN
+12 SET MDIEN=""
+13 IF PINSTYPE="CARE"
SET MDIEN=$$GETMDIEN
+14 ;IHS/SD/RLT - 01/24/06 - Patch 15 - end
+15 ;
+16 ;"Site" nodes
+17 ;S ABSP("Site","IEN")=DIALOUT
+18 ;S ABSP("Site","Switch Type")=$$SWTYPE(DIALOUT)
+19 NEW PHARMACY
+20 Begin DoDot:1
+21 NEW IEN57
SET IEN57=$ORDER(TRANSACT(""))
+22 SET PHARMACY=$PIECE(^ABSPTL(IEN57,1),U,7)
+23 SET XDATA=^ABSP(9002313.56,PHARMACY,0)
+24 SET ABSP("Site","NABP #")=$PIECE(XDATA,U,2)
+25 SET ABSP("Site","Default DEA #")=$PIECE(XDATA,U,3)
+26 SET ABSP("Envoy Terminal ID")=$PIECE(XDATA,U,6)
+27 SET ABSP("Site","Name")=$PIECE(XDATA,U)_" PHARMACY"
+28 SET ABSP("Site","Tax ID #")=$PIECE(XDATA,U,5)
+29 SET XDATA=$GET(^ABSP(9002313.56,PHARMACY,"CAID"))
+30 SET ABSP("Site","Medicaid Pharmacy #")=$PIECE(XDATA,U)
+31 SET ABSP("Site","Default CAID #")=$PIECE(XDATA,U,2)
+32 SET XDATA=$GET(^ABSP(9002313.56,PHARMACY,"NDC"))
+33 SET ABSP("Site","NDC ID")=$PIECE(XDATA,U)
+34 ; These additional nodes for paper forms only:
+35 NEW ADDR
SET ADDR=$GET(^ABSP(9002313.56,PHARMACY,"ADDR"))
+36 SET ABSP("Site","Addr")=$PIECE(ADDR,U)
IF $PIECE(ADDR,U,2)]""
Begin DoDot:2
+37 SET ABSP("Site","Addr")=ABSP("Site","Addr")_"/"_$PIECE(ADDR,U,2)
End DoDot:2
+38 SET ABSP("Site","City")=$PIECE(ADDR,U,3)
+39 SET ABSP("Site","State")=$PIECE(ADDR,U,4)
+40 SET ABSP("Site","Zip")=$PIECE(ADDR,U,5)
+41 SET ABSP("Site","Phone")=$PIECE(ADDR,U,6)
+42 SET ABSP("Site","Fax")=$PIECE(ADDR,U,7)
+43 ; contact name
SET ABSP("Site","Contact")=""
+44 ; May have special list of contact names and phone #s
+45 ; (the old NCPDP form had a line for Contact name as well as phone #)
+46 NEW X
SET X=$GET(^ABSP(9002313.56,PHARMACY,"REP"))
+47 IF $PIECE(X,U,2)=""
QUIT
+48 ; how many contact names/phone #s
NEW N
SET N=$LENGTH($PIECE(X,U,2),",")
+49 ; pick one at random
SET N=$RANDOM(N)+1
+50 SET ABSP("Site","Phone")=$PIECE($PIECE(X,U,2),",",N)
+51 SET ABSP("Site","Contact")=$PIECE($PIECE(X,U),",",N)
End DoDot:1
+52 ;
+53 SET XDATA=^DPT(PATIEN,0)
+54 SET ABSP("Patient","IEN")=PATIEN
+55 ; Patient,Name
Begin DoDot:1
+56 NEW %
IF PINSTYPE="CAID"
Begin DoDot:2
+57 SET %=$$CAIDNAME
End DoDot:2
+58 IF '$TEST
IF PINSTYPE="CARE"
Begin DoDot:2
+59 SET %=$$CARENAME
End DoDot:2
+60 IF '$TEST
SET %=""
+61 IF %=""
SET %=$PIECE(XDATA,U)
+62 SET ABSP("Patient","Name")=%
End DoDot:1
+63 SET ABSP("Patient","Sex")=$PIECE(XDATA,U,2)
+64 SET ABSP("Patient","DOB")=$PIECE(XDATA,U,3)
+65 SET ABSP("Patient","SSN")=$PIECE(XDATA,U,9)
+66 ;
+67 ;"RX" mode containing date filled
+68 ; (All of the prescriptions are the same date filled
+69 ; because they're all for the same visit. We assume.)
+70 ;IHS/OIT/CNI/RAN Patch 40 This is not the correct date
+71 ;S ABSP("RX","Date Filled")=$P($G(^AUPNVSIT(VSTIEN,0)),U,1)
+72 ;
+73 ;"Insurer" nodes
+74 ;$$INSIEN
SET (INSIEN,ABSP("Insurer","IEN"))=INSIEN
+75 SET ABSP("Cardholder","Last Name")=$$INSDNAME(2)
+76 SET ABSP("Cardholder","First Name")=$$INSDNAME(1)
+77 SET ABSP("Insurer","Relationship")=$$INSREL
+78 SET ABSP("Insurer","Person Code")=$$PERSON
+79 ;ABSP("Eligibility Clarification code")=$$ELGCLAR
+80 SET ABSP("Insurer","Group #")=$$INSGRP
+81 SET ABSP("Insurer","Policy #")=$$INSPOL
+82 ;IHS/OIT/SCR 01/15/09 patch 29
+83 SET ABSP("Insurer","Member #")=$$INSMBRNM
+84 ;
+85 ; Pharmacy number: usually NABP #, but sometimes the insurer demands
+86 ; their own insurer-assigned pharmacy number. Especially with Medicaid
+87 SET ABSP("Site","Pharmacy #")=ABSP("Site","NABP #")
+88 IF $DATA(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #","B",INSIEN))
Begin DoDot:1
+89 NEW X
SET X=$ORDER(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #","B",INSIEN,0))
+90 SET ABSP("Site","Pharmacy #")=$PIECE(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,2)
End DoDot:1
+91 ; Anachronism: Medicaid Pharmacy # is a special field,
+92 ; properly, it belongs in the INSURER-ASSIGNED #
+93 ; But that Medicaid Pharmacy # will overwrite the in INS.-ASSIGNED #
+94 IF PINSTYPE="CAID"
IF ABSP("Site","Medicaid Pharmacy #")]""
Begin DoDot:1
+95 SET ABSP("Site","Pharmacy #")=ABSP("Site","Medicaid Pharmacy #")
End DoDot:1
+96 ;"NCPDP" nodes
+97 SET NRECIEN=$PIECE($GET(^ABSPEI(INSIEN,100)),U,1)
+98 ; most of this is electronic only but retained anyhow
Begin DoDot:1
+99 SET ABSP("NCPDP","IEN")=NRECIEN
+100 IF NRECIEN
SET XDATA=$GET(^ABSPF(9002313.92,NRECIEN,1))
+101 ;
IF '$TEST
SET XDATA=""
+102 ; do not add disp fee to ingr cost on paper forms
SET $PIECE(XDATA,U,8)=0
+103 SET ABSP("NCPDP","BIN Number")=$PIECE(XDATA,U,1)
+104 SET ABSP("NCPDP","Version")=$PIECE(XDATA,U,2)
+105 SET ABSP("NCPDP","# Meds/Claim")=$PIECE(XDATA,U,3)
+106 SET ABSP("NCPDP","Envoy Plan Number")=$PIECE(XDATA,U,4)
+107 IF $PIECE(XDATA,U,8)=""
SET $PIECE(XDATA,U,8)=1
+108 SET ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=$PIECE(XDATA,U,8)
End DoDot:1
+109 ; extra info for workers comp claims
IF $$WORKREL
Begin DoDot:1
+110 DO INSWORK
+111 SET ABSP("Date of Injury")=$PIECE(^AUPNVPOV($$WORKREL,0),U,8)
End DoDot:1
+112 ;IHS/OIT/SCR 01/15/09 - added 'SPECIAL' node info
+113 ;"SPECIAL" node
+114 SET ABSP("SPECIAL","SUBSCRIBER ID")=$PIECE($GET(^ABSP(9002313.99,1,"SPECIAL")),U,4)
+115 QUIT
WORKREL() ; this is copied from ABSPOS26+/- ; changed ABSBVISI to VSTIEN
+1 ; is VSTIEN a worker's comp visit?
+2 ; If so, return value is true = pointer to ^AUPNVPOV which has
+3 ; the CAUSE OF DX listed as EMPLOYMENT RELATED
+4 NEW A,RET
SET (A,RET)=0
+5 FOR
SET A=$ORDER(^AUPNVPOV("AD",VSTIEN,A))
IF 'A
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^AUPNVPOV(A,0)),U,7)=4
Begin DoDot:2
+7 SET RET=A
End DoDot:2
End DoDot:1
IF RET
QUIT
+8 QUIT RET
+9 ; $$INSxxx functions - given PINSTYPE, PINSDA, PINSDA1
INSIEN() ; get pointer to ^AUTNINS
+1 ; (But shouldn't we directly get this from the IEN59?)
+2 IF PINSTYPE="CAID"
QUIT $PIECE($GET(^AUPNMCD(PINSDA,0)),U,2)
+3 IF PINSTYPE="PRVT"
QUIT $PIECE($GET(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U)
+4 IF PINSTYPE="CARE"
QUIT $PIECE($GET(^AUPNMCR(PINSDA,0)),U,2)
+5 IF PINSTYPE="RR"
QUIT $PIECE($GET(^AUPNRRE(PINSDA,0)),U,2)
+6 IF PINSTYPE="SELF"
QUIT ""
+7 DO IMPOSS^ABSPOSUE("P","TI","bad PINSTYPE="_PINSTYPE,,"INSIEN",$TEXT(+0))
+8 QUIT ""
INSREL() ; a single digit, 1, 2, 3, 4 = self,spouse,child,other
+1 ; X points to ^AUTTRLSH(
NEW X
SET X=+$$AUTTRLSH
IF 'X
QUIT 4
+2 ; Translate it using our own file, 9002313.81
+3 ; translate to name
SET X=$PIECE($GET(^AUTTRLSH(X,0)),U)
IF X=""
QUIT 4
+4 ; point into 9002313.81
SET X=$ORDER(^ABSPF(9002313.81,"B",X,0))
IF 'X
QUIT 4
+5 SET X=$PIECE(^ABSPF(9002313.81,X,0),U,2)
+6 QUIT $SELECT(X:X,1:4)
AUTTRLSH() ; relationship - pointer to ^AUTTRLSH
+1 IF PINSTYPE="PRVT"
QUIT $PIECE($GET(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,5)
+2 NEW X
SET X=$ORDER(^AUTTRLSH("B","SELF",0))
IF 'X
DO IMPOSS^ABSPOSUE("DB","TI","RELATIONSHIP file is missing SELF entry",,"AUTTRLSH",$TEXT(+0))
ELGCLAR() ; Eligibility clarification code
+1 ; From Paid Presc. documentation:
+2 ; 3=Full-time student; 4=Disabled dependent; 5=Dependent parent
+3 ; 6=Significant other. Required if relationship code=3 or 4 and
+4 ; patient is age 18 or over.
+5 QUIT ""
PERSON() ; Person Code
+1 ; For now, it's a simple translation from relationship code:
+2 ; 1->"01", 2->"02", etc.
+3 QUIT "0"_$$INSREL
INSGRP() ; Insurer Group #
+1 ;RLT - 2/13/06 - Patch 16
+2 ;Get Medicare D group #
+3 NEW GRPIEN
+4 SET GRPIEN=""
+5 IF PINSTYPE="CARE"&(MDIEN)
SET GRPIEN=$PIECE($GET(^AUPNMCR(PINSDA,11,MDIEN,0)),U,11)
+6 IF GRPIEN
QUIT $PIECE($GET(^AUTNEGRP(GRPIEN,0)),U,2)
+7 ;RLT - 2/13/06 - Patch 16
+8 IF PINSTYPE'="PRVT"
QUIT ""
+9 NEW X
SET X=$$INS3PPH
IF 'X
QUIT ""
+10 NEW Y
SET Y=$PIECE($GET(^AUPN3PPH(X,0)),U,6)
IF 'Y
QUIT ""
+11 ; OUTPATIENT group # if poss
NEW Z
SET Z=$PIECE($GET(^AUTNEGRP(Y,11,111,0)),U,2)
+12 ; else take the general one
IF Z=""
SET Z=$PIECE($GET(^AUTNEGRP(Y,0)),U,2)
+13 QUIT Z
INSDNAME(N) ; Insured's name
+1 NEW X
+2 IF PINSTYPE="CAID"
SET X=$$CAIDNAME
+3 IF '$TEST
IF PINSTYPE="CARE"
SET X=$$CARENAME
+4 IF '$TEST
IF PINSTYPE="SELF"!(PINSTYPE="RR")
SET X=ABSP("Patient","Name")
+5 IF '$TEST
IF PINSTYPE="PRVT"
Begin DoDot:1
+6 NEW T
SET T=$$INS3PPH
+7 ; no 3PPH?
IF 'T
SET X=""
QUIT
+8 ; Policy holder
SET X=$PIECE(^AUPN3PPH(T,0),U)
End DoDot:1
+9 IF '$TEST
DO IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSDNAME",$TEXT(+0))
+10 IF X=""
SET X=ABSP("Patient","Name")
+11 ; first name
IF N=1
QUIT $PIECE(X,",",2)
+12 ; last name
IF '$TEST
IF N=2
QUIT $PIECE(X,",",1)
+13 ; entire name
IF '$TEST
QUIT X
INSWORK ; get worker's comp-related info
+1 IF PINSTYPE'="PRVT"
QUIT
+2 NEW P
SET P=$$INS3PPH
IF 'P
QUIT
+3 NEW X
SET X=$PIECE($GET(^AUPN3PPH(P,0)),U,16)
IF 'X
QUIT
+4 SET X=$GET(^AUTNEMPL(X,0))
IF X=""
QUIT
+5 SET ABSP("Employer","Name")=$PIECE(X,U)
+6 SET ABSP("Employer","Address")=$PIECE(X,U,2)
+7 SET ABSP("Employer","City")=$PIECE(X,U,3)
+8 Begin DoDot:1
+9 NEW ST
+10 SET ABSP("Employer","State")=$PIECE(^DIC(5,ST,0),U,2)
End DoDot:1
+11 SET ABSP("Employer","Zip Code")=$PIECE(X,U,5)
+12 SET ABSP("Employer","Phone")=$PIECE(X,U,6)
+13 QUIT
INS3PPH() QUIT $PIECE($GET(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,8)
INSPOL() ; /IHS/OIT/RAM ; 15 DEC 17 - IT APPEARS THAT THIS ROUTINE HAS NOT BEEN KEPT UP
+1 ; I WONDER IF IT'S EVEN IN USE...
+2 IF PINSTYPE="CAID"
QUIT $PIECE($GET(^AUPNMCD(PINSDA,0)),U,3)
+3 ;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
+4 ;I PINSTYPE="CARE" Q $P($G(^AUPNMCR(PINSDA,0)),U,3) ; no suffix?
+5 IF PINSTYPE="CARE"
QUIT $$GETMDPOL
+6 ;IHS/SD/RLT - 01/24/06 - Patch 15 - end
+7 ; I PINSTYPE="RR" Q $P($G(^AUPNRRE(PINSDA,0)),U,4) ; no prefix?
+8 ; /IHS/OIT/RAM ; 18 DEC 17 - New method for retrieving the RR Policy Number.
IF PINSTYPE="RR"
QUIT $$GETRRE^AGUTL(PINSDA)
+9 IF PINSTYPE="SELF"
QUIT ""
+10 IF PINSTYPE'="PRVT"
DO IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSPOL",$TEXT(+0))
+11 NEW X
SET X=$$INS3PPH
+12 ; 3PPH version first
IF X
NEW Y
SET Y=$PIECE($GET(^AUPN3PPH(X,0)),U,4)
IF Y]""
QUIT Y
+13 ; else PRVT version
QUIT $PIECE($GET(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,2)
INSMBRNM() ; Member #
+1 ;IHS/OIT/SCR 01/15/09 - Patch 29
+2 NEW ABSPMNUM
+3 SET ABSPMNUM=""
+4 IF PINSTYPE="PRVT"
SET ABSPMNUM=$GET(^AUPNPRVT(PINSDA,11,PINSDA1,2))
+5 QUIT ABSPMNUM
OLDGETMDPOL() ;Updated policy number lookup for Medicare D elig.
+1 ;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
+2 NEW POL,MDPOL
+3 ;original Medicare policy#
SET POL=$PIECE($GET(^AUPNMCR(PINSDA,0)),U,3)
+4 SET MDPOL=""
+5 IF MDIEN'=""
SET MDPOL=$PIECE($GET(^AUPNMCR(PINSDA,11,MDIEN,0)),U,6)
+6 ;use Medicare D policy# if elig found
IF MDPOL'=""
SET POL=MDPOL
+7 QUIT POL
+8 ;IHS/SD/RLT - 01/24/06 - Patch 15 - end
GETMDPOL() ;EP ; /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.
+2 ; 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...
+3 NEW POL,MDPOL
SET (POL,MDPOL)=""
+4 ; MDFLAG has already been called and correct flags set - let's use them to see if it's Medicare Part D & retrieve.
+5 IF MDFLG&(MDIEN)
SET MDPOL=$PIECE($GET(^AUPNMCR(PINSDA,11,MDIEN,0)),U,6)
+6 ; If the retrieve was successful, let's return that policy #.
+7 IF MDPOL'=""
QUIT MDPOL
+8 ; If not, then let's go snag the individual's MBI if it exists...
+9 SET POL=$$GETMCR^AGUTL(PINSDA)
+10 ; if MBI exists, let's default to that & return.
+11 IF POL'=""
QUIT POL
+12 ; OK... the "new way" & Medicare D resulted in nothing. Let's fall back to the original code as a 'Plan B.'
+13 ;original
SET POL=$PIECE($GET(^AUPNMCR(PINSDA,0)),U,3)
+14 ;
+15 QUIT POL
+16 ;
CAIDNAME() QUIT $PIECE($GET(^AUPNMCD(PINSDA,21)),U)
CARENAME() ;Q $P($G(^AUPNMCR(PINSDA,21)),U)
+1 ;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
+2 ;Updated name lookup for new Medicare D elig.
+3 NEW NAME,MDNAME
+4 ;original Medicare name
SET NAME=$PIECE($GET(^AUPNMCR(PINSDA,21)),U)
+5 SET MDNAME=""
+6 IF MDIEN'=""
SET MDNAME=$PIECE($GET(^AUPNMCR(PINSDA,11,MDIEN,0)),U,5)
+7 ;use Medicare D name if elig found
SET NAME=MDNAME
+8 QUIT NAME
+9 ;IHS/SD/RLT - 01/24/06 - Patch 15 - end
GETMDIEN() ;Get IEN for Medicare D elig record lookup.
+1 ;IHS/SD/RLT - 01/24/06 - Patch 15 - begin
+2 ;New Medicare D eligibiiltiy lookup.
+3 NEW MDFND,D1
+4 SET MDFND=""
+5 SET D1="A"
+6 FOR
SET D1=$ORDER(^AUPNMCR(PINSDA,11,D1),-1)
IF 'D1!(MDFND)
QUIT
Begin DoDot:1
+7 ;coverage type
IF $PIECE($GET(^AUPNMCR(PINSDA,11,D1,0)),U,3)'="D"
QUIT
+8 SET MDFND=1
+9 SET MDIEN=D1
End DoDot:1
+10 IF 'MDFND
QUIT ""
+11 QUIT MDIEN
+12 ;IHS/SD/RLT - 01/24/06 - Patch 15 - end
