ABSPOSCC ; IHS/FCS/DRS - Set up ABSP() ; [ 05/09/2003 9:37 AM ]
;;1.0;PHARMACY POINT OF SALE;**1,4,6,9,11,15,16,17,19,20,21,29,37,40,42,46,47**;JUN 01, 2001;Build 38
;---
; IHS/SD/lwj 03/12/02 some insurers are requiring the entire
; untranslated value as the cardholder id - new array budget
; added to hold the "raw" value for transmission
; New entry in ABSP("Insurer","Full Policy #")=$$INSPOL
;---
; IHS/SD/lwj 11/25/02 Medicaid date of birth change
; Pam Schweitzer requested that for all the Medicaid formats we use
; the Medicaid DOB rather than the Patient DOB currently in use.
; A new variable ABSP("Patient","Caid DOB") was added to this routine.
;---
; IHS/SD/lwj 5/5/03 Changes needed for Idaho Medicaid 5.1.
; Idaho Medicaid went live and forgot to tell us that the Cardholder
; first and last names are now required. We tested with them without
; problems, but go-live things failed. Added logic from ABSPOSFC
; to retrieve the cardholder first and last names.
;---
;IHS/SD/lwj 12/04/03
; New 5.1 formats are now requiring the patient's address info
; be included on the claim. (Foundation Health Generic 5.1 for
; Blackhawk was the first.) Subroutine added to retrieve the
; information from the ^DPT file and populate the array for use
; in fields 322, 323, 324 and 325.
;---
;IHS/SD/lwj 4/30/04 patch 11
; Cannot assume state value is populated - $G added to
; GETAINFO. Problem seen at Santa Fe.
;---
;IHS/SD/RLT - 01/24/06 - Patch 15
; Access new MPD elig data.
;---
;IHS/SD/RLT - 02/13/06 - Patch 16
; Access Group # in MPD elig data.
;---
;IHS/SD/RLT - 04/10/06 - Patch 17
; Access DOB in MPD elig data.
;---
;IHS/SD/RLT - 04/25/06 - Patch 17
; Access RR D elig data.
;---
;IHS/SD/RLT - 1/16/07 - Patch 19
; Elig beg and end dates for Medi-Cal format.
; Issue date needs to be appended to cardholder ID.
;---
;IHS/SD/RLT - 3/15/07 - Patch 20
; NPI
;---
;IHS/SD/RLT - 5/10/07 - Patch 21
; Added Medicare to Person Code
;---
;IHS/SD/RLT - 5/14/07 - Patch 21
; Updated NPI
;---
;IHS/OIT/RCS - 8/12/13 - Patch 46
; Added 'ABSP("Patient","Location")' variable ;; /IHS/OIT/RAM 22 MAY 17; *Should* be "Residence" variable; modifying.
Q
; Called from ABSPOSCA from ABSPOSQG from ABSPOSQ2
; Sets up the ABSP(*) nodes
; GETINFO gets the patient/visit-level stuff
;
GETINFO(DIALOUT,PATIEN,VSTIEN,PINS,INSIEN) ;EP
;Manage local variables
N XDATA,NRECIEN,I,I2
; PINSDA = pointer into insurance elig file,
; PINSDA1 = 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
;
;Medicare D
N MDFLG,MDIEN
S (MDFLG,MDIEN)=""
I PINSTYPE="CARE" D
. S MDFLG=$$MDFLG^ABSPOSCG()
. S:MDFLG MDIEN=$P(PINS,",",3)
;
;Railroad D
N RRDFLG,RRDIEN
S (RRDFLG,RRDIEN)=""
I PINSTYPE="RR" D
. S RRDFLG=$$RRDFLG^ABSPOSCG()
. S:RRDFLG RRDIEN=$P(PINS,",",3)
;
;"Site" nodes
S ABSP("Site","IEN")=DIALOUT
S ABSP("Site","Switch Type")=$$SWTYPE(DIALOUT)
N PHARMACY
D
. N ABSBRXI S ABSBRXI=$O(RXILIST(""))
. S PHARMACY=$P(^ABSPT(ABSBRXI,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 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)
. ;Get OP Site to find Institution - NPI
. S ABSP("Outpatient Site")=$P($G(^ABSPT(ABSBRXI,1)),U,4)
. S ABSP("Institution")=""
. I ABSP("Outpatient Site")'="" D
.. S ABSP("Institution")=$P($G(^PS(59,ABSP("Outpatient Site"),"INI")),U,2)
;
;Get Institution NPI #
S ABSP("Site","NPI #")=-1
I ABSP("Institution")'="" D
. S ABSP("Site","NPI #")=$P($$NPI^XUSNPI("Organization_ID",ABSP("Institution")),U)
;
;Get Global NPI Flag
S ABSP("Global NPI Flag")=$P($G(^ABSP(9002313.99,1,"NPI")),U)
;
;"Patient" nodes
S XDATA=^DPT(PATIEN,0)
S ABSP("Patient","IEN")=PATIEN
D ; Patient,Name
. N % I PINSTYPE="CAID" D
. . S %=$$CAIDNAME^ABSPOSCH
. E I PINSTYPE="CARE" D
. . S %=$$CARENAME^ABSPOSCH
. E I PINSTYPE="RR" D
. . S %=$$RRNAME^ABSPOSCG
. 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)
S ABSP("Patient","EMAIL")=$P($G(^AUPNPAT(PATIEN,18)),U,2) ;Patch 42
S ABSP("Patient","Residence")="01" ;Patch 46, Default value -- for the "Residence" (384) node, not the "Location" (307) node.
; /IHS/OIT/RAM 22 MAY 17; Here is where the patch for CR07945 needs to go to acquire Patient Residence from Patient Reg.
; From Nicholas Daniel; here's the new _tentative_ fields:
; PATIENT RESIDENCE file #9999999.361 (new) (data comes with file) ;; CODE field #.01 (new) ;; DESCRIPTION field #.02 (new)
; PATIENT file #9000001 ;; PATIENT RESIDENCE field #1803 (new)
; _if_ they need just the pointer, here's the change:
S I=$$GET1^DIQ(9000001,PATIEN,1803,"I")
I +I S ABSP("Patient","Residence")=$P($G(^AUTTPRES(I,0)),"^",2)
I ABSP("Patient","Residence")="" S ABSP("Patient","Residence")="01" ; /IHS/OIT/RAM/ 23 JUL 17 ; KEEP DEFAULT OF '01' IF FIELD IS EMPTY.
; Assuming they don't need the 'description' field from the new file; I would think that they'd retrieve that from the pointer or code.
; /IHS/OIT/RAM 22 MAY 17; End of notes regarding patch for CR07945.
;IHS/SD/lwj 12/04/03 patch 9 get address info
D GETAINFO^ABSPOSCH
;
;IHS/SD/lwj 11/25/02 get Medicaid DOB
S ABSP("Patient","Medicaid DOB")=$$CAIDDOB^ABSPOSCH
;
S ABSP("Patient","Medicare DOB")=""
S:PINSTYPE="CARE" ABSP("Patient","Medicare DOB")=$$CAREDOB^ABSPOSCH
;
S ABSP("Patient","Railroad DOB")=""
;S:PINSTYPE="RR" ABSP("Patient","Railroad DOB")=$$RRDOB^ABSPOSCG
S:PINSTYPE="RR" ABSP("Patient","Medicare DOB")=$$RRDOB^ABSPOSCG
;
;"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 fill date should be set up at Prescription level in ABSPOSCD
;S ABSP("RX","Date Filled")=$P($G(^AUPNVSIT(VSTIEN,0)),U,1)
;
;"Insurer" nodes
S (INSIEN,ABSP("Insurer","IEN"))=INSIEN ;$$INSIEN
;
;Get Insurer NPI Flag
S ABSP("Insurer NPI Flag")=$P($G(^ABSPEI(+INSIEN,100)),U,14)
;
;Set Send NPI
;S ABSP("Send NPI")=""
;S:ABSP("Global NPI Flag")=1!(ABSP("Insurer NPI Flag")=1) ABSP("Send NPI")=1
;I ((ABSP("Global NPI Flag")=1)&(ABSP("Insurer NPI Flag")'=0))!((ABSP("Global NPI Flag")'=1)&(ABSP("Insurer NPI Flag")=1)) D
;. S ABSP("Send NPI")=1
S ABSP("Send Pharmacy NPI")=""
S ABSP("Send Prescriber NPI")=""
I (ABSP("Insurer NPI Flag")=""&(ABSP("Global NPI Flag")=1))!(ABSP("Insurer NPI Flag")="1") D
. S ABSP("Send Pharmacy NPI")=1 ;both
. S ABSP("Send Prescriber NPI")=1
I ABSP("Insurer NPI Flag")="P" D
. S ABSP("Send Pharmacy NPI")=1 ;pharmacy only
I ABSP("Insurer NPI Flag")="D" D
. S ABSP("Send Prescriber NPI")=1 ;send prescriber only
;
;IHS/SD/lwj 5/5/03 added cardholder info for Idaho Medicaid
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
;S ABSP("Eligibility Clarification code")=$$ELGCLAR
S ABSP("Insurer","Group #")=$$INSGRP
; Try to strip blanks, punctuation ; ABSP*1.0T7*3
;S ABSP("Insurer","Policy #")=$$INSPOL ; ABSP*1.0T7*3
S ABSP("Insurer","Policy #")=$TR($$INSPOL,"- /.","") ; ABSP*1.0T7*3
;
;IHS/OIT/SCR 01/15/09 patch 29
S ABSP("Insurer","Member #")=$$INSMBRNM
;
; IHS/SD/lwj 03/12/02 some insurers require entire, untranslated
; value
S ABSP("Insurer","Full Policy #")=$$INSPOL ;IHS/SD/lwj 03/12/02
;
;Issue (begin elig) date needed to append to Medi-Cal cardholder ID
S ABSP("Insurer","Elig Dates")=$$CAIDELDT^ABSPOSCH
S ABSP("Insurer","Elig Beg Dt")=$P(ABSP("Insurer","Elig Dates"),U)
S ABSP("Insurer","Elig End Dt")=$P(ABSP("Insurer","Elig Dates"),U,2)
;
; 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)
. ;IHS/OIT/SCR 02/12/09 - Collect "Site", "Pharmacy - MED-CAL ID" 'INFO
. S ABSP("Site","MED-CAL Subscriber #")=$P(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,3)
. ;IHS/OIT/RAN 03/01/10 - Patch 37 Collect "Site", "Pharmacy - CA FAMILY PACT ID" 'INFO
. S ABSP("Site","CA FAMILY PACT ID")=$P(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,4)
; 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" D
. I ABSP("Site","Medicaid Pharmacy #")'="" D
.. S ABSP("Site","Pharmacy #")=ABSP("Site","Medicaid Pharmacy #")
. I ABSP("Site","Medicaid Pharmacy #")=""&(ABSP("Site","Default CAID #")'="") D
.. S ABSP("Site","Pharmacy #")=ABSP("Site","Default CAID #") ;RLT - Patch 20
;
;Set fields 202 and 201
S ABSP("Header","Service Prov ID Qual")="07" ;default for 202
;I ABSP("Send NPI")=1&(ABSP("Site","NPI #")>0) D
I ABSP("Send Pharmacy NPI")=1&(ABSP("Site","NPI #")>0) D
. S ABSP("Header","Service Prov ID Qual")="01"
. S ABSP("Site","Pharmacy #")=ABSP("Site","NPI #")
;
;"NCPDP" nodes
;S NRECIEN=$P($G(^ABSPEI(INSIEN,100)),U,1)
;IHS/OIT/CASSEVERN/RAN - 02/09/2011 - Patch 42 -New code for D.0 - START
;D:NRECIEN'=""
;. S ABSP("NCPDP","IEN")=NRECIEN
;The Conversion has been run....no longer need formats
I $G(^ABSP(9002313.99,1,"ABSPICNV"))=1 D
. Q:'$D(^ABSPEI(INSIEN))
. N INSARRAY
. D GETS^DIQ(9002313.4,INSIEN_",","100.15;100.16;100.19;100.2","","INSARRAY")
. S ABSP("NCPDP","Version")=INSARRAY(9002313.4,INSIEN_",",100.15) ;NEW PLACE TO STORE NCPDP VERSION
. S ABSP("NCPDP","BIN Number")=INSARRAY(9002313.4,INSIEN_",",100.16)
. S ABSP("NCPDP","# Meds/Claim")=INSARRAY(9002313.4,INSIEN_",",100.19)
. S ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=INSARRAY(9002313.4,INSIEN_",",100.2)
. S ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=$S(ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")="NO":0,1:1)
. S ABSP("NCPDP","IEN")=1
ELSE D
. ;This is the old code that gets info from format.
. S NRECIEN=$P($G(^ABSPEI(INSIEN,100)),U,1)
. S ABSP("NCPDP","IEN")=NRECIEN
. Q:'NRECIEN
. S XDATA=$G(^ABSPF(9002313.92,NRECIEN,1))
. 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)
;IHS/OIT/CASSEVERN/RAN - 02/09/2011 - Patch 42 -New code for D.0 - STOP
Q
;
; $$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))
Q X
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
; Check the new location just recently mispatched into registration.
; Something's goofy, FILEMAN, P^DI, 8, 1, GLOBAL doesn't show this
; field, but it is in ^DD(9000006.11,.12,...)
N X
;I PINSTYPE="PRVT" S X=$P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,12) ;
;E S X=""
S X="" ;RLT 21
I PINSTYPE="PRVT" S X=$P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,12)
I PINSTYPE="CARE"&(MDFLG&(MDIEN)) S X=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,7)
; otherwise, a simple translation from relationship code:
; 1->"01", 2->"02", etc.
I X="" S X="0"_$$INSREL
Q X
INSGRP() ; Insurer Grp #
N GRPIEN
S GRPIEN=""
;RLT 21
;S:PINSTYPE="CARE"&(MDIEN) GRPIEN=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,11)
S:PINSTYPE="CARE"&(MDFLG&(MDIEN)) GRPIEN=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,11)
Q:GRPIEN $P($G(^AUTNEGRP(GRPIEN,0)),U,2)
S:PINSTYPE="RR"&(RRDFLG&(RRDIEN)) GRPIEN=$P($G(^AUPNRRE(PINSDA,11,RRDIEN,0)),U,11)
Q:GRPIEN $P($G(^AUTNEGRP(GRPIEN,0)),U,2)
;OIT/CAS/RCS Patch 47, Add Medicaid Group #
S:PINSTYPE="CAID" GRPIEN=$P($G(^AUPNMCD(PINSDA,0)),U,17)
Q:GRPIEN $P($G(^AUTNEGRP(GRPIEN,0)),U,2)
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) ; OP group #
I Z="" S Z=$P($G(^AUTNEGRP(Y,0)),U,2) ; else general
Q Z
;
; V1.0 Patch 6
; IHS/SD/lwj 5/5/03 for Idaho Medicaid to get cardholder first and last name.
; Taken directly from ABSPOSFC routine.
;
INSDNAME(N) ; Insured's name
N X
I PINSTYPE="CAID" S X=$$CAIDNAME^ABSPOSCH
E I PINSTYPE="CARE" S X=$$CARENAME^ABSPOSCH
E I PINSTYPE="RR" S X=$$RRNAME^ABSPOSCG
E I PINSTYPE="SELF" S X=$G(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
;
Q ""
;
INS3PPH() Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,8)
INSPOL() I PINSTYPE="CAID" Q $P($G(^AUPNMCD(PINSDA,0)),U,3)
;I PINSTYPE="CARE" Q $P($G(^AUPNMCR(PINSDA,0)),U,3) ; no suffix?
I PINSTYPE="CARE" Q $$GETMDPOL^ABSPOSCG
;I PINSTYPE="RR" Q $P($G(^AUPNRRE(PINSDA,0)),U,4) ; no prefix?
I PINSTYPE="RR" Q $$GETRRDPL^ABSPOSCG
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 first
Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,2) ; else PRVT
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
SWTYPE(D) ;EP - from ABSPOSC4 - given pointer to dial-out
; Is it NDC or ENVOY?
N X S X=^ABSP(9002313.55,D,0)
I $P(X,U,3)]"" Q $P(X,U,3)
I $P(X,U)["NDC" Q "NDC"
I $P(X,U)["ENVOY" Q "ENVOY"
D IMPOSS^ABSPOSUE("P","TI","Bad switch type for dialout "_D,,"SWTYPE",$T(+0))
Q "" ; should never happen
ABSPOSCC ; IHS/FCS/DRS - Set up ABSP() ; [ 05/09/2003 9:37 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**1,4,6,9,11,15,16,17,19,20,21,29,37,40,42,46,47**;JUN 01, 2001;Build 38
+2 ;---
+3 ; IHS/SD/lwj 03/12/02 some insurers are requiring the entire
+4 ; untranslated value as the cardholder id - new array budget
+5 ; added to hold the "raw" value for transmission
+6 ; New entry in ABSP("Insurer","Full Policy #")=$$INSPOL
+7 ;---
+8 ; IHS/SD/lwj 11/25/02 Medicaid date of birth change
+9 ; Pam Schweitzer requested that for all the Medicaid formats we use
+10 ; the Medicaid DOB rather than the Patient DOB currently in use.
+11 ; A new variable ABSP("Patient","Caid DOB") was added to this routine.
+12 ;---
+13 ; IHS/SD/lwj 5/5/03 Changes needed for Idaho Medicaid 5.1.
+14 ; Idaho Medicaid went live and forgot to tell us that the Cardholder
+15 ; first and last names are now required. We tested with them without
+16 ; problems, but go-live things failed. Added logic from ABSPOSFC
+17 ; to retrieve the cardholder first and last names.
+18 ;---
+19 ;IHS/SD/lwj 12/04/03
+20 ; New 5.1 formats are now requiring the patient's address info
+21 ; be included on the claim. (Foundation Health Generic 5.1 for
+22 ; Blackhawk was the first.) Subroutine added to retrieve the
+23 ; information from the ^DPT file and populate the array for use
+24 ; in fields 322, 323, 324 and 325.
+25 ;---
+26 ;IHS/SD/lwj 4/30/04 patch 11
+27 ; Cannot assume state value is populated - $G added to
+28 ; GETAINFO. Problem seen at Santa Fe.
+29 ;---
+30 ;IHS/SD/RLT - 01/24/06 - Patch 15
+31 ; Access new MPD elig data.
+32 ;---
+33 ;IHS/SD/RLT - 02/13/06 - Patch 16
+34 ; Access Group # in MPD elig data.
+35 ;---
+36 ;IHS/SD/RLT - 04/10/06 - Patch 17
+37 ; Access DOB in MPD elig data.
+38 ;---
+39 ;IHS/SD/RLT - 04/25/06 - Patch 17
+40 ; Access RR D elig data.
+41 ;---
+42 ;IHS/SD/RLT - 1/16/07 - Patch 19
+43 ; Elig beg and end dates for Medi-Cal format.
+44 ; Issue date needs to be appended to cardholder ID.
+45 ;---
+46 ;IHS/SD/RLT - 3/15/07 - Patch 20
+47 ; NPI
+48 ;---
+49 ;IHS/SD/RLT - 5/10/07 - Patch 21
+50 ; Added Medicare to Person Code
+51 ;---
+52 ;IHS/SD/RLT - 5/14/07 - Patch 21
+53 ; Updated NPI
+54 ;---
+55 ;IHS/OIT/RCS - 8/12/13 - Patch 46
+56 ; Added 'ABSP("Patient","Location")' variable ;; /IHS/OIT/RAM 22 MAY 17; *Should* be "Residence" variable; modifying.
+57 QUIT
+58 ; Called from ABSPOSCA from ABSPOSQG from ABSPOSQ2
+59 ; Sets up the ABSP(*) nodes
+60 ; GETINFO gets the patient/visit-level stuff
+61 ;
GETINFO(DIALOUT,PATIEN,VSTIEN,PINS,INSIEN) ;EP
+1 ;Manage local variables
+2 NEW XDATA,NRECIEN,I,I2
+3 ; PINSDA = pointer into insurance elig file,
+4 ; PINSDA1 = pointer into multiple of ^AUPNPRVT where appropriate
+5 NEW PINSDA,PINSDA1,PINSTYPE
SET PINSDA=$PIECE(PINS,",",2)
SET PINSTYPE=$PIECE(PINS,",")
+6 ; else PINSDA1 undef
IF PINSTYPE="PRVT"
SET PINSDA1=$PIECE(PINS,",",3)
+7 SET ABSP("VisitIEN")=VSTIEN
+8 ;
+9 ;Medicare D
+10 NEW MDFLG,MDIEN
+11 SET (MDFLG,MDIEN)=""
+12 IF PINSTYPE="CARE"
Begin DoDot:1
+13 SET MDFLG=$$MDFLG^ABSPOSCG()
+14 IF MDFLG
SET MDIEN=$PIECE(PINS,",",3)
End DoDot:1
+15 ;
+16 ;Railroad D
+17 NEW RRDFLG,RRDIEN
+18 SET (RRDFLG,RRDIEN)=""
+19 IF PINSTYPE="RR"
Begin DoDot:1
+20 SET RRDFLG=$$RRDFLG^ABSPOSCG()
+21 IF RRDFLG
SET RRDIEN=$PIECE(PINS,",",3)
End DoDot:1
+22 ;
+23 ;"Site" nodes
+24 SET ABSP("Site","IEN")=DIALOUT
+25 SET ABSP("Site","Switch Type")=$$SWTYPE(DIALOUT)
+26 NEW PHARMACY
+27 Begin DoDot:1
+28 NEW ABSBRXI
SET ABSBRXI=$ORDER(RXILIST(""))
+29 SET PHARMACY=$PIECE(^ABSPT(ABSBRXI,1),U,7)
+30 SET XDATA=^ABSP(9002313.56,PHARMACY,0)
+31 SET ABSP("Site","NABP #")=$PIECE(XDATA,U,2)
+32 SET ABSP("Site","Default DEA #")=$PIECE(XDATA,U,3)
+33 SET ABSP("Envoy Terminal ID")=$PIECE(XDATA,U,6)
+34 SET XDATA=$GET(^ABSP(9002313.56,PHARMACY,"CAID"))
+35 SET ABSP("Site","Medicaid Pharmacy #")=$PIECE(XDATA,U)
+36 SET ABSP("Site","Default CAID #")=$PIECE(XDATA,U,2)
+37 SET XDATA=$GET(^ABSP(9002313.56,PHARMACY,"NDC"))
+38 SET ABSP("Site","NDC ID")=$PIECE(XDATA,U)
+39 ;Get OP Site to find Institution - NPI
+40 SET ABSP("Outpatient Site")=$PIECE($GET(^ABSPT(ABSBRXI,1)),U,4)
+41 SET ABSP("Institution")=""
+42 IF ABSP("Outpatient Site")'=""
Begin DoDot:2
+43 SET ABSP("Institution")=$PIECE($GET(^PS(59,ABSP("Outpatient Site"),"INI")),U,2)
End DoDot:2
End DoDot:1
+44 ;
+45 ;Get Institution NPI #
+46 SET ABSP("Site","NPI #")=-1
+47 IF ABSP("Institution")'=""
Begin DoDot:1
+48 SET ABSP("Site","NPI #")=$PIECE($$NPI^XUSNPI("Organization_ID",ABSP("Institution")),U)
End DoDot:1
+49 ;
+50 ;Get Global NPI Flag
+51 SET ABSP("Global NPI Flag")=$PIECE($GET(^ABSP(9002313.99,1,"NPI")),U)
+52 ;
+53 ;"Patient" nodes
+54 SET XDATA=^DPT(PATIEN,0)
+55 SET ABSP("Patient","IEN")=PATIEN
+56 ; Patient,Name
Begin DoDot:1
+57 NEW %
IF PINSTYPE="CAID"
Begin DoDot:2
+58 SET %=$$CAIDNAME^ABSPOSCH
End DoDot:2
+59 IF '$TEST
IF PINSTYPE="CARE"
Begin DoDot:2
+60 SET %=$$CARENAME^ABSPOSCH
End DoDot:2
+61 IF '$TEST
IF PINSTYPE="RR"
Begin DoDot:2
+62 SET %=$$RRNAME^ABSPOSCG
End DoDot:2
+63 IF '$TEST
SET %=""
+64 IF %=""
SET %=$PIECE(XDATA,U)
+65 SET ABSP("Patient","Name")=%
End DoDot:1
+66 SET ABSP("Patient","Sex")=$PIECE(XDATA,U,2)
+67 SET ABSP("Patient","DOB")=$PIECE(XDATA,U,3)
+68 SET ABSP("Patient","SSN")=$PIECE(XDATA,U,9)
+69 ;Patch 42
SET ABSP("Patient","EMAIL")=$PIECE($GET(^AUPNPAT(PATIEN,18)),U,2)
+70 ;Patch 46, Default value -- for the "Residence" (384) node, not the "Location" (307) node.
SET ABSP("Patient","Residence")="01"
+71 ; /IHS/OIT/RAM 22 MAY 17; Here is where the patch for CR07945 needs to go to acquire Patient Residence from Patient Reg.
+72 ; From Nicholas Daniel; here's the new _tentative_ fields:
+73 ; PATIENT RESIDENCE file #9999999.361 (new) (data comes with file) ;; CODE field #.01 (new) ;; DESCRIPTION field #.02 (new)
+74 ; PATIENT file #9000001 ;; PATIENT RESIDENCE field #1803 (new)
+75 ; _if_ they need just the pointer, here's the change:
+76 SET I=$$GET1^DIQ(9000001,PATIEN,1803,"I")
+77 IF +I
SET ABSP("Patient","Residence")=$PIECE($GET(^AUTTPRES(I,0)),"^",2)
+78 ; /IHS/OIT/RAM/ 23 JUL 17 ; KEEP DEFAULT OF '01' IF FIELD IS EMPTY.
IF ABSP("Patient","Residence")=""
SET ABSP("Patient","Residence")="01"
+79 ; Assuming they don't need the 'description' field from the new file; I would think that they'd retrieve that from the pointer or code.
+80 ; /IHS/OIT/RAM 22 MAY 17; End of notes regarding patch for CR07945.
+81 ;IHS/SD/lwj 12/04/03 patch 9 get address info
+82 DO GETAINFO^ABSPOSCH
+83 ;
+84 ;IHS/SD/lwj 11/25/02 get Medicaid DOB
+85 SET ABSP("Patient","Medicaid DOB")=$$CAIDDOB^ABSPOSCH
+86 ;
+87 SET ABSP("Patient","Medicare DOB")=""
+88 IF PINSTYPE="CARE"
SET ABSP("Patient","Medicare DOB")=$$CAREDOB^ABSPOSCH
+89 ;
+90 SET ABSP("Patient","Railroad DOB")=""
+91 ;S:PINSTYPE="RR" ABSP("Patient","Railroad DOB")=$$RRDOB^ABSPOSCG
+92 IF PINSTYPE="RR"
SET ABSP("Patient","Medicare DOB")=$$RRDOB^ABSPOSCG
+93 ;
+94 ;"RX" mode containing date filled
+95 ; (All of the prescriptions are the same date filled
+96 ; because they're all for the same visit. We assume.)
+97 ;IHS/OIT/CNI/RAN patch 40 This is NOT the fill date should be set up at Prescription level in ABSPOSCD
+98 ;S ABSP("RX","Date Filled")=$P($G(^AUPNVSIT(VSTIEN,0)),U,1)
+99 ;
+100 ;"Insurer" nodes
+101 ;$$INSIEN
SET (INSIEN,ABSP("Insurer","IEN"))=INSIEN
+102 ;
+103 ;Get Insurer NPI Flag
+104 SET ABSP("Insurer NPI Flag")=$PIECE($GET(^ABSPEI(+INSIEN,100)),U,14)
+105 ;
+106 ;Set Send NPI
+107 ;S ABSP("Send NPI")=""
+108 ;S:ABSP("Global NPI Flag")=1!(ABSP("Insurer NPI Flag")=1) ABSP("Send NPI")=1
+109 ;I ((ABSP("Global NPI Flag")=1)&(ABSP("Insurer NPI Flag")'=0))!((ABSP("Global NPI Flag")'=1)&(ABSP("Insurer NPI Flag")=1)) D
+110 ;. S ABSP("Send NPI")=1
+111 SET ABSP("Send Pharmacy NPI")=""
+112 SET ABSP("Send Prescriber NPI")=""
+113 IF (ABSP("Insurer NPI Flag")=""&(ABSP("Global NPI Flag")=1))!(ABSP("Insurer NPI Flag")="1")
Begin DoDot:1
+114 ;both
SET ABSP("Send Pharmacy NPI")=1
+115 SET ABSP("Send Prescriber NPI")=1
End DoDot:1
+116 IF ABSP("Insurer NPI Flag")="P"
Begin DoDot:1
+117 ;pharmacy only
SET ABSP("Send Pharmacy NPI")=1
End DoDot:1
+118 IF ABSP("Insurer NPI Flag")="D"
Begin DoDot:1
+119 ;send prescriber only
SET ABSP("Send Prescriber NPI")=1
End DoDot:1
+120 ;
+121 ;IHS/SD/lwj 5/5/03 added cardholder info for Idaho Medicaid
+122 SET ABSP("Cardholder","Last Name")=$$INSDNAME(2)
+123 SET ABSP("Cardholder","First Name")=$$INSDNAME(1)
+124 ;
+125 SET ABSP("Insurer","Relationship")=$$INSREL
+126 SET ABSP("Insurer","Person Code")=$$PERSON
+127 ;S ABSP("Eligibility Clarification code")=$$ELGCLAR
+128 SET ABSP("Insurer","Group #")=$$INSGRP
+129 ; Try to strip blanks, punctuation ; ABSP*1.0T7*3
+130 ;S ABSP("Insurer","Policy #")=$$INSPOL ; ABSP*1.0T7*3
+131 ; ABSP*1.0T7*3
SET ABSP("Insurer","Policy #")=$TRANSLATE($$INSPOL,"- /.","")
+132 ;
+133 ;IHS/OIT/SCR 01/15/09 patch 29
+134 SET ABSP("Insurer","Member #")=$$INSMBRNM
+135 ;
+136 ; IHS/SD/lwj 03/12/02 some insurers require entire, untranslated
+137 ; value
+138 ;IHS/SD/lwj 03/12/02
SET ABSP("Insurer","Full Policy #")=$$INSPOL
+139 ;
+140 ;Issue (begin elig) date needed to append to Medi-Cal cardholder ID
+141 SET ABSP("Insurer","Elig Dates")=$$CAIDELDT^ABSPOSCH
+142 SET ABSP("Insurer","Elig Beg Dt")=$PIECE(ABSP("Insurer","Elig Dates"),U)
+143 SET ABSP("Insurer","Elig End Dt")=$PIECE(ABSP("Insurer","Elig Dates"),U,2)
+144 ;
+145 ; Pharmacy number: usually NABP #, but sometimes the insurer demands
+146 ; their own insurer-assigned pharmacy number. Especially with Medicaid
+147 SET ABSP("Site","Pharmacy #")=ABSP("Site","NABP #")
+148 IF $DATA(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #","B",INSIEN))
Begin DoDot:1
+149 NEW X
SET X=$ORDER(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #","B",INSIEN,0))
+150 SET ABSP("Site","Pharmacy #")=$PIECE(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,2)
+151 ;IHS/OIT/SCR 02/12/09 - Collect "Site", "Pharmacy - MED-CAL ID" 'INFO
+152 SET ABSP("Site","MED-CAL Subscriber #")=$PIECE(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,3)
+153 ;IHS/OIT/RAN 03/01/10 - Patch 37 Collect "Site", "Pharmacy - CA FAMILY PACT ID" 'INFO
+154 SET ABSP("Site","CA FAMILY PACT ID")=$PIECE(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,4)
End DoDot:1
+155 ; Anachronism: Medicaid Pharmacy # is a special field,
+156 ; properly, it belongs in the INSURER-ASSIGNED #
+157 ; But that Medicaid Pharmacy # will overwrite the in INS.-ASSIGNED #
+158 IF PINSTYPE="CAID"
Begin DoDot:1
+159 IF ABSP("Site","Medicaid Pharmacy #")'=""
Begin DoDot:2
+160 SET ABSP("Site","Pharmacy #")=ABSP("Site","Medicaid Pharmacy #")
End DoDot:2
+161 IF ABSP("Site","Medicaid Pharmacy #")=""&(ABSP("Site","Default CAID #")'="")
Begin DoDot:2
+162 ;RLT - Patch 20
SET ABSP("Site","Pharmacy #")=ABSP("Site","Default CAID #")
End DoDot:2
End DoDot:1
+163 ;
+164 ;Set fields 202 and 201
+165 ;default for 202
SET ABSP("Header","Service Prov ID Qual")="07"
+166 ;I ABSP("Send NPI")=1&(ABSP("Site","NPI #")>0) D
+167 IF ABSP("Send Pharmacy NPI")=1&(ABSP("Site","NPI #")>0)
Begin DoDot:1
+168 SET ABSP("Header","Service Prov ID Qual")="01"
+169 SET ABSP("Site","Pharmacy #")=ABSP("Site","NPI #")
End DoDot:1
+170 ;
+171 ;"NCPDP" nodes
+172 ;S NRECIEN=$P($G(^ABSPEI(INSIEN,100)),U,1)
+173 ;IHS/OIT/CASSEVERN/RAN - 02/09/2011 - Patch 42 -New code for D.0 - START
+174 ;D:NRECIEN'=""
+175 ;. S ABSP("NCPDP","IEN")=NRECIEN
+176 ;The Conversion has been run....no longer need formats
+177 IF $GET(^ABSP(9002313.99,1,"ABSPICNV"))=1
Begin DoDot:1
+178 IF '$DATA(^ABSPEI(INSIEN))
QUIT
+179 NEW INSARRAY
+180 DO GETS^DIQ(9002313.4,INSIEN_",","100.15;100.16;100.19;100.2","","INSARRAY")
+181 ;NEW PLACE TO STORE NCPDP VERSION
SET ABSP("NCPDP","Version")=INSARRAY(9002313.4,INSIEN_",",100.15)
+182 SET ABSP("NCPDP","BIN Number")=INSARRAY(9002313.4,INSIEN_",",100.16)
+183 SET ABSP("NCPDP","# Meds/Claim")=INSARRAY(9002313.4,INSIEN_",",100.19)
+184 SET ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=INSARRAY(9002313.4,INSIEN_",",100.2)
+185 SET ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=$SELECT(ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")="NO":0,1:1)
+186 SET ABSP("NCPDP","IEN")=1
End DoDot:1
+187 IF '$TEST
Begin DoDot:1
+188 ;This is the old code that gets info from format.
+189 SET NRECIEN=$PIECE($GET(^ABSPEI(INSIEN,100)),U,1)
+190 SET ABSP("NCPDP","IEN")=NRECIEN
+191 IF 'NRECIEN
QUIT
+192 SET XDATA=$GET(^ABSPF(9002313.92,NRECIEN,1))
+193 SET ABSP("NCPDP","BIN Number")=$PIECE(XDATA,U,1)
+194 SET ABSP("NCPDP","Version")=$PIECE(XDATA,U,2)
+195 SET ABSP("NCPDP","# Meds/Claim")=$PIECE(XDATA,U,3)
+196 SET ABSP("NCPDP","Envoy Plan Number")=$PIECE(XDATA,U,4)
+197 IF $PIECE(XDATA,U,8)=""
SET $PIECE(XDATA,U,8)=1
+198 SET ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=$PIECE(XDATA,U,8)
End DoDot:1
+199 ;IHS/OIT/CASSEVERN/RAN - 02/09/2011 - Patch 42 -New code for D.0 - STOP
+200 QUIT
+201 ;
+202 ; $$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))
+3 QUIT X
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 ; Check the new location just recently mispatched into registration.
+2 ; Something's goofy, FILEMAN, P^DI, 8, 1, GLOBAL doesn't show this
+3 ; field, but it is in ^DD(9000006.11,.12,...)
+4 NEW X
+5 ;I PINSTYPE="PRVT" S X=$P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,12) ;
+6 ;E S X=""
+7 ;RLT 21
SET X=""
+8 IF PINSTYPE="PRVT"
SET X=$PIECE($GET(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,12)
+9 IF PINSTYPE="CARE"&(MDFLG&(MDIEN))
SET X=$PIECE($GET(^AUPNMCR(PINSDA,11,MDIEN,0)),U,7)
+10 ; otherwise, a simple translation from relationship code:
+11 ; 1->"01", 2->"02", etc.
+12 IF X=""
SET X="0"_$$INSREL
+13 QUIT X
INSGRP() ; Insurer Grp #
+1 NEW GRPIEN
+2 SET GRPIEN=""
+3 ;RLT 21
+4 ;S:PINSTYPE="CARE"&(MDIEN) GRPIEN=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,11)
+5 IF PINSTYPE="CARE"&(MDFLG&(MDIEN))
SET GRPIEN=$PIECE($GET(^AUPNMCR(PINSDA,11,MDIEN,0)),U,11)
+6 IF GRPIEN
QUIT $PIECE($GET(^AUTNEGRP(GRPIEN,0)),U,2)
+7 IF PINSTYPE="RR"&(RRDFLG&(RRDIEN))
SET GRPIEN=$PIECE($GET(^AUPNRRE(PINSDA,11,RRDIEN,0)),U,11)
+8 IF GRPIEN
QUIT $PIECE($GET(^AUTNEGRP(GRPIEN,0)),U,2)
+9 ;OIT/CAS/RCS Patch 47, Add Medicaid Group #
+10 IF PINSTYPE="CAID"
SET GRPIEN=$PIECE($GET(^AUPNMCD(PINSDA,0)),U,17)
+11 IF GRPIEN
QUIT $PIECE($GET(^AUTNEGRP(GRPIEN,0)),U,2)
+12 IF PINSTYPE'="PRVT"
QUIT ""
+13 NEW X
SET X=$$INS3PPH
IF 'X
QUIT ""
+14 NEW Y
SET Y=$PIECE($GET(^AUPN3PPH(X,0)),U,6)
IF 'Y
QUIT ""
+15 ; OP group #
NEW Z
SET Z=$PIECE($GET(^AUTNEGRP(Y,11,111,0)),U,2)
+16 ; else general
IF Z=""
SET Z=$PIECE($GET(^AUTNEGRP(Y,0)),U,2)
+17 QUIT Z
+18 ;
+19 ; V1.0 Patch 6
+20 ; IHS/SD/lwj 5/5/03 for Idaho Medicaid to get cardholder first and last name.
+21 ; Taken directly from ABSPOSFC routine.
+22 ;
INSDNAME(N) ; Insured's name
+1 NEW X
+2 IF PINSTYPE="CAID"
SET X=$$CAIDNAME^ABSPOSCH
+3 IF '$TEST
IF PINSTYPE="CARE"
SET X=$$CARENAME^ABSPOSCH
+4 IF '$TEST
IF PINSTYPE="RR"
SET X=$$RRNAME^ABSPOSCG
+5 IF '$TEST
IF PINSTYPE="SELF"
SET X=$GET(ABSP("Patient","Name"))
+6 IF '$TEST
IF PINSTYPE="PRVT"
Begin DoDot:1
+7 NEW T
SET T=$$INS3PPH
+8 ; no 3PPH?
IF 'T
SET X=""
QUIT
+9 ; Policy holder
SET X=$PIECE(^AUPN3PPH(T,0),U)
End DoDot:1
+10 IF '$TEST
DO IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSDNAME",$TEXT(+0))
+11 IF X=""
SET X=ABSP("Patient","Name")
+12 ; first name
IF N=1
QUIT $PIECE(X,",",2)
+13 ; last name
IF '$TEST
IF N=2
QUIT $PIECE(X,",",1)
+14 ; entire name
IF '$TEST
QUIT X
+15 ;
+16 QUIT ""
+17 ;
INS3PPH() QUIT $PIECE($GET(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,8)
INSPOL() IF PINSTYPE="CAID"
QUIT $PIECE($GET(^AUPNMCD(PINSDA,0)),U,3)
+1 ;I PINSTYPE="CARE" Q $P($G(^AUPNMCR(PINSDA,0)),U,3) ; no suffix?
+2 IF PINSTYPE="CARE"
QUIT $$GETMDPOL^ABSPOSCG
+3 ;I PINSTYPE="RR" Q $P($G(^AUPNRRE(PINSDA,0)),U,4) ; no prefix?
+4 IF PINSTYPE="RR"
QUIT $$GETRRDPL^ABSPOSCG
+5 IF PINSTYPE="SELF"
QUIT ""
+6 IF PINSTYPE'="PRVT"
DO IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSPOL",$TEXT(+0))
+7 NEW X
SET X=$$INS3PPH
+8 ; 3PPH first
IF X
NEW Y
SET Y=$PIECE($GET(^AUPN3PPH(X,0)),U,4)
IF Y]""
QUIT Y
+9 ; else PRVT
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
SWTYPE(D) ;EP - from ABSPOSC4 - given pointer to dial-out
+1 ; Is it NDC or ENVOY?
+2 NEW X
SET X=^ABSP(9002313.55,D,0)
+3 IF $PIECE(X,U,3)]""
QUIT $PIECE(X,U,3)
+4 IF $PIECE(X,U)["NDC"
QUIT "NDC"
+5 IF $PIECE(X,U)["ENVOY"
QUIT "ENVOY"
+6 DO IMPOSS^ABSPOSUE("P","TI","Bad switch type for dialout "_D,,"SWTYPE",$TEXT(+0))
+7 ; should never happen
QUIT ""
