Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPOSCC

ABSPOSCC.m

Go to the documentation of this file. 
  1. 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
  1.  ;---
  1.  ; IHS/SD/lwj 03/12/02  some insurers are requiring the entire
  1.  ; untranslated value as the cardholder id - new array budget
  1.  ; added to hold the "raw" value for transmission
  1.  ; New entry in ABSP("Insurer","Full Policy #")=$$INSPOL
  1.  ;---
  1.  ; IHS/SD/lwj 11/25/02 Medicaid date of birth change
  1.  ; Pam Schweitzer requested that for all the Medicaid formats we use
  1.  ; the Medicaid DOB rather than the Patient DOB currently in use.
  1.  ; A new variable ABSP("Patient","Caid DOB") was added to this routine.
  1.  ;---
  1.  ; IHS/SD/lwj 5/5/03  Changes needed for Idaho Medicaid 5.1.
  1.  ; Idaho Medicaid went live and forgot to tell us that the Cardholder
  1.  ; first and last names are now required.  We tested with them without
  1.  ; problems, but go-live things failed.  Added logic from ABSPOSFC
  1.  ; to retrieve the cardholder first and last names.
  1.  ;---
  1.  ;IHS/SD/lwj 12/04/03
  1.  ; New 5.1 formats are now requiring the patient's address info
  1.  ; be included on the claim.  (Foundation Health Generic 5.1 for
  1.  ; Blackhawk was the first.)  Subroutine added to retrieve the 
  1.  ; information from the ^DPT file and populate the array for use
  1.  ; in fields 322, 323, 324 and 325.
  1.  ;---
  1.  ;IHS/SD/lwj 4/30/04 patch 11
  1.  ; Cannot assume state value is populated - $G added to
  1.  ; GETAINFO.  Problem seen at Santa Fe.
  1.  ;---
  1.  ;IHS/SD/RLT - 01/24/06 - Patch 15
  1.  ;    Access new MPD elig data.
  1.  ;---
  1.  ;IHS/SD/RLT - 02/13/06 - Patch 16
  1.  ;    Access Group # in MPD elig data.
  1.  ;---
  1.  ;IHS/SD/RLT - 04/10/06 - Patch 17
  1.  ;    Access DOB in MPD elig data.
  1.  ;---
  1.  ;IHS/SD/RLT - 04/25/06 - Patch 17
  1.  ;    Access RR D elig data.
  1.  ;---
  1.  ;IHS/SD/RLT - 1/16/07 - Patch 19
  1.  ;    Elig beg and end dates for Medi-Cal format.
  1.  ;    Issue date needs to be appended to cardholder ID.
  1.  ;---
  1.  ;IHS/SD/RLT - 3/15/07 - Patch 20
  1.  ;    NPI
  1.  ;---
  1.  ;IHS/SD/RLT - 5/10/07 - Patch 21
  1.  ;    Added Medicare to Person Code
  1.  ;---
  1.  ;IHS/SD/RLT - 5/14/07 - Patch 21
  1.  ;    Updated NPI
  1.  ;---
  1.  ;IHS/OIT/RCS - 8/12/13 - Patch 46
  1.  ;    Added 'ABSP("Patient","Location")' variable ;; /IHS/OIT/RAM 22 MAY 17; *Should* be "Residence" variable; modifying.
  1.  Q
  1.  ; Called from ABSPOSCA from ABSPOSQG from ABSPOSQ2
  1.  ; Sets up the ABSP(*) nodes
  1.  ; GETINFO gets the patient/visit-level stuff
  1.  ;
  1. GETINFO(DIALOUT,PATIEN,VSTIEN,PINS,INSIEN) ;EP
  1.  ;Manage local variables
  1.  N XDATA,NRECIEN,I,I2
  1.  ; PINSDA = pointer into insurance elig file,
  1.  ; PINSDA1 = pointer into multiple of ^AUPNPRVT where appropriate
  1.  N PINSDA,PINSDA1,PINSTYPE S PINSDA=$P(PINS,",",2),PINSTYPE=$P(PINS,",")
  1.  I PINSTYPE="PRVT" S PINSDA1=$P(PINS,",",3) ; else PINSDA1 undef
  1.  S ABSP("VisitIEN")=VSTIEN
  1.  ;
  1.  ;Medicare D
  1.  N MDFLG,MDIEN
  1.  S (MDFLG,MDIEN)=""
  1.  I PINSTYPE="CARE" D
  1.  . S MDFLG=$$MDFLG^ABSPOSCG()
  1.  . S:MDFLG MDIEN=$P(PINS,",",3)
  1.  ;
  1.  ;Railroad D
  1.  N RRDFLG,RRDIEN
  1.  S (RRDFLG,RRDIEN)=""
  1.  I PINSTYPE="RR" D
  1.  . S RRDFLG=$$RRDFLG^ABSPOSCG()
  1.  . S:RRDFLG RRDIEN=$P(PINS,",",3)
  1.  ;
  1.  ;"Site" nodes
  1.  S ABSP("Site","IEN")=DIALOUT
  1.  S ABSP("Site","Switch Type")=$$SWTYPE(DIALOUT)
  1.  N PHARMACY
  1.  D
  1.  . N ABSBRXI S ABSBRXI=$O(RXILIST(""))
  1.  . S PHARMACY=$P(^ABSPT(ABSBRXI,1),U,7)
  1.  . S XDATA=^ABSP(9002313.56,PHARMACY,0)
  1.  . S ABSP("Site","NABP #")=$P(XDATA,U,2)
  1.  . S ABSP("Site","Default DEA #")=$P(XDATA,U,3)
  1.  . S ABSP("Envoy Terminal ID")=$P(XDATA,U,6)
  1.  . S XDATA=$G(^ABSP(9002313.56,PHARMACY,"CAID"))
  1.  . S ABSP("Site","Medicaid Pharmacy #")=$P(XDATA,U)
  1.  . S ABSP("Site","Default CAID #")=$P(XDATA,U,2)
  1.  . S XDATA=$G(^ABSP(9002313.56,PHARMACY,"NDC"))
  1.  . S ABSP("Site","NDC ID")=$P(XDATA,U)
  1.  . ;Get OP Site to find Institution - NPI
  1.  . S ABSP("Outpatient Site")=$P($G(^ABSPT(ABSBRXI,1)),U,4)
  1.  . S ABSP("Institution")=""
  1.  . I ABSP("Outpatient Site")'="" D
  1.  .. S ABSP("Institution")=$P($G(^PS(59,ABSP("Outpatient Site"),"INI")),U,2)
  1.  ;
  1.  ;Get Institution NPI #
  1.  S ABSP("Site","NPI #")=-1
  1.  I ABSP("Institution")'="" D
  1.  . S ABSP("Site","NPI #")=$P($$NPI^XUSNPI("Organization_ID",ABSP("Institution")),U)
  1.  ;
  1.  ;Get Global NPI Flag
  1.  S ABSP("Global NPI Flag")=$P($G(^ABSP(9002313.99,1,"NPI")),U)
  1.  ;
  1.  ;"Patient" nodes
  1.  S XDATA=^DPT(PATIEN,0)
  1.  S ABSP("Patient","IEN")=PATIEN
  1.  D  ; Patient,Name
  1.  . N % I PINSTYPE="CAID" D
  1.  . . S %=$$CAIDNAME^ABSPOSCH
  1.  . E  I PINSTYPE="CARE" D
  1.  . . S %=$$CARENAME^ABSPOSCH
  1.  . E  I PINSTYPE="RR" D
  1.  . . S %=$$RRNAME^ABSPOSCG
  1.  . E  S %=""
  1.  . I %="" S %=$P(XDATA,U)
  1.  . S ABSP("Patient","Name")=%
  1.  S ABSP("Patient","Sex")=$P(XDATA,U,2)
  1.  S ABSP("Patient","DOB")=$P(XDATA,U,3)
  1.  S ABSP("Patient","SSN")=$P(XDATA,U,9)
  1.  S ABSP("Patient","EMAIL")=$P($G(^AUPNPAT(PATIEN,18)),U,2) ;Patch 42
  1.  S ABSP("Patient","Residence")="01" ;Patch 46, Default value -- for the "Residence" (384) node, not the "Location" (307) node.
  1.  ; /IHS/OIT/RAM 22 MAY 17; Here is where the patch for CR07945 needs to go to acquire Patient Residence from Patient Reg.
  1.  ; From Nicholas Daniel; here's the new _tentative_ fields:
  1.  ; PATIENT RESIDENCE file #9999999.361  (new) (data comes with file) ;; CODE field #.01 (new) ;; DESCRIPTION field #.02 (new)
  1.  ; PATIENT file #9000001 ;; PATIENT RESIDENCE field #1803  (new)
  1.  ; _if_ they need just the pointer, here's the change:
  1.  S I=$$GET1^DIQ(9000001,PATIEN,1803,"I")
  1.  I +I S ABSP("Patient","Residence")=$P($G(^AUTTPRES(I,0)),"^",2)
  1.  I ABSP("Patient","Residence")="" S ABSP("Patient","Residence")="01" ; /IHS/OIT/RAM/ 23 JUL 17 ; KEEP DEFAULT OF '01' IF FIELD IS EMPTY.
  1.  ; 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.
  1.  ; /IHS/OIT/RAM 22 MAY 17; End of notes regarding patch for CR07945.
  1.  ;IHS/SD/lwj 12/04/03  patch 9 get address info
  1.  D GETAINFO^ABSPOSCH
  1.  ;
  1.  ;IHS/SD/lwj 11/25/02 get Medicaid DOB
  1.  S ABSP("Patient","Medicaid DOB")=$$CAIDDOB^ABSPOSCH
  1.  ;
  1.  S ABSP("Patient","Medicare DOB")=""
  1.  S:PINSTYPE="CARE" ABSP("Patient","Medicare DOB")=$$CAREDOB^ABSPOSCH
  1.  ;
  1.  S ABSP("Patient","Railroad DOB")=""
  1.  ;S:PINSTYPE="RR" ABSP("Patient","Railroad DOB")=$$RRDOB^ABSPOSCG
  1.  S:PINSTYPE="RR" ABSP("Patient","Medicare DOB")=$$RRDOB^ABSPOSCG
  1.  ;
  1.  ;"RX" mode containing date filled
  1.  ; (All of the prescriptions are the same date filled
  1.  ;  because they're all for the same visit.  We assume.)
  1.  ;IHS/OIT/CNI/RAN patch 40 This is NOT the fill date should be set up at Prescription level in ABSPOSCD
  1.  ;S ABSP("RX","Date Filled")=$P($G(^AUPNVSIT(VSTIEN,0)),U,1)
  1.  ;
  1.  ;"Insurer" nodes
  1.  S (INSIEN,ABSP("Insurer","IEN"))=INSIEN ;$$INSIEN
  1.  ;
  1.  ;Get Insurer NPI Flag
  1.  S ABSP("Insurer NPI Flag")=$P($G(^ABSPEI(+INSIEN,100)),U,14)
  1.  ;
  1.  ;Set Send NPI
  1.  ;S ABSP("Send NPI")=""
  1.  ;S:ABSP("Global NPI Flag")=1!(ABSP("Insurer NPI Flag")=1) ABSP("Send NPI")=1
  1.  ;I ((ABSP("Global NPI Flag")=1)&(ABSP("Insurer NPI Flag")'=0))!((ABSP("Global NPI Flag")'=1)&(ABSP("Insurer NPI Flag")=1)) D
  1.  ;. S ABSP("Send NPI")=1
  1.  S ABSP("Send Pharmacy NPI")=""
  1.  S ABSP("Send Prescriber NPI")=""
  1.  I (ABSP("Insurer NPI Flag")=""&(ABSP("Global NPI Flag")=1))!(ABSP("Insurer NPI Flag")="1") D
  1.  . S ABSP("Send Pharmacy NPI")=1       ;both
  1.  . S ABSP("Send Prescriber NPI")=1
  1.  I ABSP("Insurer NPI Flag")="P" D
  1.  . S ABSP("Send Pharmacy NPI")=1       ;pharmacy only
  1.  I ABSP("Insurer NPI Flag")="D" D
  1.  . S ABSP("Send Prescriber NPI")=1     ;send prescriber only
  1.  ;
  1.  ;IHS/SD/lwj  5/5/03 added cardholder info for Idaho Medicaid
  1.  S ABSP("Cardholder","Last Name")=$$INSDNAME(2)
  1.  S ABSP("Cardholder","First Name")=$$INSDNAME(1)
  1.  ;
  1.  S ABSP("Insurer","Relationship")=$$INSREL
  1.  S ABSP("Insurer","Person Code")=$$PERSON
  1.  ;S ABSP("Eligibility Clarification code")=$$ELGCLAR
  1.  S ABSP("Insurer","Group #")=$$INSGRP
  1.  ; Try to strip blanks, punctuation ; ABSP*1.0T7*3
  1.  ;S ABSP("Insurer","Policy #")=$$INSPOL ; ABSP*1.0T7*3
  1.  S ABSP("Insurer","Policy #")=$TR($$INSPOL,"- /.","") ; ABSP*1.0T7*3
  1.  ;
  1.  ;IHS/OIT/SCR 01/15/09 patch 29
  1.  S ABSP("Insurer","Member #")=$$INSMBRNM
  1.  ;
  1.  ; IHS/SD/lwj 03/12/02  some insurers require entire, untranslated
  1.  ; value
  1.  S ABSP("Insurer","Full Policy #")=$$INSPOL ;IHS/SD/lwj 03/12/02
  1.  ;
  1.  ;Issue (begin elig) date needed to append to Medi-Cal cardholder ID
  1.  S ABSP("Insurer","Elig Dates")=$$CAIDELDT^ABSPOSCH
  1.  S ABSP("Insurer","Elig Beg Dt")=$P(ABSP("Insurer","Elig Dates"),U)
  1.  S ABSP("Insurer","Elig End Dt")=$P(ABSP("Insurer","Elig Dates"),U,2)
  1.  ;
  1.  ; Pharmacy number:  usually NABP #, but sometimes the insurer demands
  1.  ; their own insurer-assigned pharmacy number.  Especially with Medicaid
  1.  S ABSP("Site","Pharmacy #")=ABSP("Site","NABP #")
  1.  I $D(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #","B",INSIEN)) D
  1.  . N X S X=$O(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #","B",INSIEN,0))
  1.  . S ABSP("Site","Pharmacy #")=$P(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,2)
  1.  . ;IHS/OIT/SCR 02/12/09 - Collect "Site", "Pharmacy - MED-CAL ID" 'INFO
  1.  . S ABSP("Site","MED-CAL Subscriber #")=$P(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,3)
  1.  . ;IHS/OIT/RAN 03/01/10 - Patch 37 Collect "Site", "Pharmacy - CA FAMILY PACT ID" 'INFO
  1.  . S ABSP("Site","CA FAMILY PACT ID")=$P(^ABSP(9002313.56,PHARMACY,"INSURER-ASSIGNED #",X,0),U,4)
  1.  ; Anachronism:  Medicaid Pharmacy # is a special field,
  1.  ; properly, it belongs in the INSURER-ASSIGNED #
  1.  ; But that Medicaid Pharmacy # will overwrite the in INS.-ASSIGNED #
  1.  I PINSTYPE="CAID" D
  1.  . I ABSP("Site","Medicaid Pharmacy #")'="" D
  1.  .. S ABSP("Site","Pharmacy #")=ABSP("Site","Medicaid Pharmacy #")
  1.  . I ABSP("Site","Medicaid Pharmacy #")=""&(ABSP("Site","Default CAID #")'="") D
  1.  .. S ABSP("Site","Pharmacy #")=ABSP("Site","Default CAID #")     ;RLT - Patch 20
  1.  ;
  1.  ;Set fields 202 and 201
  1.  S ABSP("Header","Service Prov ID Qual")="07"           ;default for 202
  1.  ;I ABSP("Send NPI")=1&(ABSP("Site","NPI #")>0) D
  1.  I ABSP("Send Pharmacy NPI")=1&(ABSP("Site","NPI #")>0) D
  1.  . S ABSP("Header","Service Prov ID Qual")="01"
  1.  . S ABSP("Site","Pharmacy #")=ABSP("Site","NPI #")
  1.  ;
  1.  ;"NCPDP" nodes
  1.  ;S NRECIEN=$P($G(^ABSPEI(INSIEN,100)),U,1)
  1.  ;IHS/OIT/CASSEVERN/RAN - 02/09/2011 - Patch 42 -New code for D.0 - START
  1.  ;D:NRECIEN'=""
  1.  ;. S ABSP("NCPDP","IEN")=NRECIEN
  1.  ;The Conversion has been run....no longer need formats
  1.  I $G(^ABSP(9002313.99,1,"ABSPICNV"))=1 D
  1.  . Q:'$D(^ABSPEI(INSIEN))
  1.  . N INSARRAY
  1.  . D GETS^DIQ(9002313.4,INSIEN_",","100.15;100.16;100.19;100.2","","INSARRAY")
  1.  . S ABSP("NCPDP","Version")=INSARRAY(9002313.4,INSIEN_",",100.15) ;NEW PLACE TO STORE NCPDP VERSION
  1.  . S ABSP("NCPDP","BIN Number")=INSARRAY(9002313.4,INSIEN_",",100.16)
  1.  . S ABSP("NCPDP","# Meds/Claim")=INSARRAY(9002313.4,INSIEN_",",100.19)
  1.  . S ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=INSARRAY(9002313.4,INSIEN_",",100.2)
  1.  . S ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=$S(ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")="NO":0,1:1)
  1.  . S ABSP("NCPDP","IEN")=1
  1.  ELSE  D
  1.  . ;This is the old code that gets info from format.
  1.  . S NRECIEN=$P($G(^ABSPEI(INSIEN,100)),U,1)
  1.  . S ABSP("NCPDP","IEN")=NRECIEN
  1.  . Q:'NRECIEN
  1.  . S XDATA=$G(^ABSPF(9002313.92,NRECIEN,1))
  1.  . S ABSP("NCPDP","BIN Number")=$P(XDATA,U,1)
  1.  . S ABSP("NCPDP","Version")=$P(XDATA,U,2)
  1.  . S ABSP("NCPDP","# Meds/Claim")=$P(XDATA,U,3)
  1.  . S ABSP("NCPDP","Envoy Plan Number")=$P(XDATA,U,4)
  1.  . I $P(XDATA,U,8)="" S $P(XDATA,U,8)=1
  1.  . S ABSP("NCPDP","Add Disp. Fee to Ingr. Cost")=$P(XDATA,U,8)
  1.  ;IHS/OIT/CASSEVERN/RAN - 02/09/2011 - Patch 42 -New code for D.0 - STOP
  1.  Q
  1.  ;
  1.  ; $$INSxxx functions - given PINSTYPE, PINSDA, PINSDA1
  1. INSIEN() ; get pointer to ^AUTNINS
  1.  ; (But shouldn't we directly get this from the IEN59?)
  1.  I PINSTYPE="CAID" Q $P($G(^AUPNMCD(PINSDA,0)),U,2)
  1.  I PINSTYPE="PRVT" Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U)
  1.  I PINSTYPE="CARE" Q $P($G(^AUPNMCR(PINSDA,0)),U,2)
  1.  I PINSTYPE="RR" Q $P($G(^AUPNRRE(PINSDA,0)),U,2)
  1.  I PINSTYPE="SELF" Q ""
  1.  D IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSIEN",$T(+0))
  1.  Q
  1. INSREL() ; a single digit, 1, 2, 3, 4 = self,spouse,child,other
  1.  N X S X=+$$AUTTRLSH Q:'X 4 ; X points to ^AUTTRLSH(
  1.  ; Translate it using our own file, 9002313.81
  1.  S X=$P($G(^AUTTRLSH(X,0)),U) Q:X="" 4 ; translate to name
  1.  S X=$O(^ABSPF(9002313.81,"B",X,0)) Q:'X 4 ; point into 9002313.81
  1.  S X=$P(^ABSPF(9002313.81,X,0),U,2)
  1.  Q $S(X:X,1:4)
  1. AUTTRLSH()         ; relationship - pointer to ^AUTTRLSH
  1.  I PINSTYPE="PRVT" Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,5)
  1.  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))
  1.  Q X
  1. ELGCLAR()          ; Eligibility clarification code
  1.  ; From Paid Presc. documentation:
  1.  ; 3=Full-time student; 4=Disabled dependent; 5=Dependent parent
  1.  ; 6=Significant other.  Required if relationship code=3 or 4 and
  1.  ; patient is age 18 or over.
  1.  Q ""
  1. PERSON() ; Person Code
  1.  ; Check the new location just recently mispatched into registration.
  1.  ; Something's goofy, FILEMAN, P^DI, 8, 1, GLOBAL doesn't show this
  1.  ;  field, but it is in ^DD(9000006.11,.12,...)
  1.  N X
  1.  ;I PINSTYPE="PRVT" S X=$P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,12) ; 
  1.  ;E  S X=""
  1.  S X=""        ;RLT 21
  1.  I PINSTYPE="PRVT" S X=$P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,12)
  1.  I PINSTYPE="CARE"&(MDFLG&(MDIEN)) S X=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,7)
  1.  ; otherwise, a simple translation from relationship code:
  1.  ; 1->"01", 2->"02", etc.
  1.  I X="" S X="0"_$$INSREL
  1.  Q X
  1. INSGRP() ; Insurer Grp #
  1.  N GRPIEN
  1.  S GRPIEN=""
  1.  ;RLT 21
  1.  ;S:PINSTYPE="CARE"&(MDIEN) GRPIEN=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,11)
  1.  S:PINSTYPE="CARE"&(MDFLG&(MDIEN)) GRPIEN=$P($G(^AUPNMCR(PINSDA,11,MDIEN,0)),U,11)
  1.  Q:GRPIEN $P($G(^AUTNEGRP(GRPIEN,0)),U,2)
  1.  S:PINSTYPE="RR"&(RRDFLG&(RRDIEN)) GRPIEN=$P($G(^AUPNRRE(PINSDA,11,RRDIEN,0)),U,11)
  1.  Q:GRPIEN $P($G(^AUTNEGRP(GRPIEN,0)),U,2)
  1.  ;OIT/CAS/RCS Patch 47, Add Medicaid Group #
  1.  S:PINSTYPE="CAID" GRPIEN=$P($G(^AUPNMCD(PINSDA,0)),U,17)
  1.  Q:GRPIEN $P($G(^AUTNEGRP(GRPIEN,0)),U,2)
  1.  I PINSTYPE'="PRVT" Q ""
  1.  N X S X=$$INS3PPH Q:'X ""
  1.  N Y S Y=$P($G(^AUPN3PPH(X,0)),U,6) Q:'Y ""
  1.  N Z S Z=$P($G(^AUTNEGRP(Y,11,111,0)),U,2) ; OP group #
  1.  I Z="" S Z=$P($G(^AUTNEGRP(Y,0)),U,2) ; else general
  1.  Q Z
  1.  ;
  1.  ; V1.0  Patch 6
  1.  ; IHS/SD/lwj 5/5/03 for Idaho Medicaid to get cardholder first and last name.
  1.  ; Taken directly from ABSPOSFC routine.
  1.  ;
  1. INSDNAME(N) ; Insured's name
  1.  N X
  1.  I PINSTYPE="CAID" S X=$$CAIDNAME^ABSPOSCH
  1.  E  I PINSTYPE="CARE" S X=$$CARENAME^ABSPOSCH
  1.  E  I PINSTYPE="RR" S X=$$RRNAME^ABSPOSCG
  1.  E  I PINSTYPE="SELF" S X=$G(ABSP("Patient","Name"))
  1.  E  I PINSTYPE="PRVT" D
  1.  . N T S T=$$INS3PPH
  1.  . I 'T S X="" Q  ; no 3PPH?
  1.  . S X=$P(^AUPN3PPH(T,0),U) ; Policy holder
  1.  E  D IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSDNAME",$T(+0))
  1.  I X="" S X=ABSP("Patient","Name")
  1.  I N=1 Q $P(X,",",2) ; first name
  1.  E  I N=2 Q $P(X,",",1) ; last name
  1.  E  Q X ; entire name
  1.  ;
  1.  Q ""
  1.  ;
  1. INS3PPH()           Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,8)
  1. INSPOL() I PINSTYPE="CAID" Q $P($G(^AUPNMCD(PINSDA,0)),U,3)
  1.  ;I PINSTYPE="CARE" Q $P($G(^AUPNMCR(PINSDA,0)),U,3) ; no suffix?
  1.  I PINSTYPE="CARE" Q $$GETMDPOL^ABSPOSCG
  1.  ;I PINSTYPE="RR" Q $P($G(^AUPNRRE(PINSDA,0)),U,4) ; no prefix?
  1.  I PINSTYPE="RR" Q $$GETRRDPL^ABSPOSCG
  1.  I PINSTYPE="SELF" Q ""
  1.  I PINSTYPE'="PRVT" D IMPOSS^ABSPOSUE("P","TI","Bad PINSTYPE="_PINSTYPE,,"INSPOL",$T(+0))
  1.  N X S X=$$INS3PPH
  1.  I X N Y S Y=$P($G(^AUPN3PPH(X,0)),U,4) I Y]"" Q Y ; 3PPH first
  1.  Q $P($G(^AUPNPRVT(PINSDA,11,PINSDA1,0)),U,2) ; else PRVT
  1. INSMBRNM()  ; Member #
  1.  ;IHS/OIT/SCR 01/15/09 - Patch 29
  1.  N ABSPMNUM
  1.  S ABSPMNUM=""
  1.  S:PINSTYPE="PRVT" ABSPMNUM=$G(^AUPNPRVT(PINSDA,11,PINSDA1,2))
  1.  Q ABSPMNUM
  1. SWTYPE(D)          ;EP - from ABSPOSC4 - given pointer to dial-out
  1.  ; Is it NDC or ENVOY?
  1.  N X S X=^ABSP(9002313.55,D,0)
  1.  I $P(X,U,3)]"" Q $P(X,U,3)
  1.  I $P(X,U)["NDC" Q "NDC"
  1.  I $P(X,U)["ENVOY" Q "ENVOY"
  1.  D IMPOSS^ABSPOSUE("P","TI","Bad switch type for dialout "_D,,"SWTYPE",$T(+0))
  1.  Q "" ; should never happen