ABSPOSFC.m

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