VPSRPC26 ;BPOIFO/EL,SLOIFO/BT - Patient Demographic (continue);07/31/14 13:07
;;1.0;VA POINT OF SERVICE (KIOSKS);**4,14**;Jul 31, 2014;Build 26
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External Reference DBIA#
; ------------------------
; #2056 - DIQ call (Supported)
; #2701 - MPIF001 call (Supported)
; #3860 - DGPFAPI call (Controlled Sub)
; #4289 - PRCAHV call (Controlled Sub)
; #4419 - IBBAPI call (Supported)
; #4425 - ^DGS( references (Controlled Sub)
; #4462 - $$GETSHAD^DGUTL3 (Supported)
; #4499 - $$LST^EASECU (Controlled Sub)
; #4807 - $$RDIS^DGRPDB (Supported)
; #6107 - PCDETAIL^ORWPT1 call (Controlled Sub)
; #10035 - ^DPT( references (Supported)
; #10103 - XLFDT call (Supported)
; #10147 - $$RXST^IBARXEU (Supported)
QUIT
;
IBB(VPSARR,DFN) ; Insurance Info
N VPSIBB,VPSIBFLD S VPSIBFLD="1,10,11,13,14,21"
N VAL S VAL=$$INSUR^IBBAPI(DFN,,"ABR",.VPSIBB,VPSIBFLD)
QUIT:VAL'>0
;
N VPSFL,VPSIEN
N SEQ S SEQ=""
;
F S SEQ=$O(VPSIBB("IBBAPI","INSUR",SEQ)) Q:SEQ="" D
. S VPSFL="2.312",VPSIEN=DFN_";"_SEQ
. ; Insurance Company Name
. S VAL=$G(VPSIBB("IBBAPI","INSUR",SEQ,1))
. S VAL=$P(VAL,U,2) D SET(.VPSARR,36,VPSIEN,.01,VAL)
. ; Policy Effective Date
. S VAL=$G(VPSIBB("IBBAPI","INSUR",SEQ,10))
. D SET(.VPSARR,VPSFL,VPSIEN,8,VAL)
. ; Policy Expiration Date
. S VAL=$G(VPSIBB("IBBAPI","INSUR",SEQ,11))
. D SET(.VPSARR,VPSFL,VPSIEN,3,VAL)
. ; Subscribe Name
. S VAL=$G(VPSIBB("IBBAPI","INSUR",SEQ,13))
. D SET(.VPSARR,VPSFL,VPSIEN,17,VAL)
. ; Subscribe ID
. S VAL=$G(VPSIBB("IBBAPI","INSUR",SEQ,14))
. D SET(.VPSARR,VPSFL,VPSIEN,1,VAL)
;
QUIT
;
REC(VPSARR,DFN) ; Patient Record Flag
N PRF,NPRF,PRFFIL,PRFLAG,VAL
S NPRF=$$GETACT^DGPFAPI(DFN,"VPSREC") ;Retrieve all ACTIVE Patient record flag assignments
;
; Store all Patient Record Flags and Assigment Narratives into result array (VPSARR)
F PRF=1:1:NPRF D
. ;store flag type
. S VAL=$P(VPSREC(PRF,"FLAGTYPE"),U,2)
. S PRFLAG=$P(VPSREC(PRF,"FLAG"),U)
. I VAL'="",PRFLAG'="" D
. . S PRFFIL=$P($P(PRFLAG,"DGPF(",2),",")
. . I PRFFIL'="" D SET(.VPSARR,PRFFIL,DFN,".03",VAL,"FLAG TYPE")
. ;store flag name
. S VAL=$P(VPSREC(PRF,"FLAG"),U,2) D SET(.VPSARR,"26.13",DFN,".02",VAL)
. D STNARR(PRF,.VPSREC) ; Store ASSIGNMENT NARRATIVE (word-processing) for this counter
;
QUIT
;
STNARR(PRF,VPSREC) ; Store ASSIGNMENT NARRATIVE (word-processing) into result array (VPSARR)
N VAL,NARRCNT S NARRCNT=""
F S NARRCNT=$O(VPSREC(PRF,"NARR",NARRCNT)) Q:NARRCNT="" D
. S VAL=$G(VPSREC(PRF,"NARR",NARRCNT,0)) D SET(.VPSARR,"26.132",DFN,".01",VAL)
QUIT
;
DGS(VPSARR,DFN) ; Pre-Registration Audit
N VPSFL S VPSFL="41.41"
N DGIEN S DGIEN=$O(^DGS(VPSFL,"ADC",DFN,""),-1)
D SET(.VPSARR,VPSFL,DFN,1,DGIEN)
QUIT
;
BAL(VPSARR,DFN) ; BALANCE-OWED
N VPSICN S VPSICN=$$GETICN^MPIF001(DFN)
N ICN S ICN=$P(VPSICN,"V")
N VAL,BAL S BAL=$$BALANCE^PRCAHV(.VAL,ICN,"ALL")
I BAL=1 D SET(.VPSARR,430,DFN,"COMPUTED",VAL,"BALANCE")
QUIT
;
OTH(VPSARR,DFN) ; Other info not in known category
N VAL
S VAL=$$GET1^DIQ(2,DFN_",",.323,"E") D SET(.VPSARR,2,DFN,.323,VAL) ;Period of Service
S VAL=$$GET1^DIQ(2,DFN_",",1100.01,"E") D SET(.VPSARR,2,DFN,1100.01,VAL) ; Fugitive Felon Flag
S VAL=$$GET1^DIQ(2,DFN_",",.109,"E") D SET(.VPSARR,2,DFN,.109,VAL) ; Exclude From Facility DIRECTORY?
S VAL=$$GET1^DIQ(2,DFN_",",63,"E") D SET(.VPSARR,2,DFN,63,VAL) ; Laboratory Reference
S VAL=$$GET1^DIQ(2,DFN_",",.305,"E") D SET(.VPSARR,2,DFN,.305,VAL) ; Unemployable
QUIT
;
POW(VPSARR,DFN) ; POW information
N VAL
S VAL=$$GET1^DIQ(2,DFN_",",.525,"E") D SET(.VPSARR,2,DFN,".525",VAL) ; POW Status Indicated?
S VAL=$$GET1^DIQ(2,DFN_",",.526,"E") D SET(.VPSARR,2,DFN,".526",VAL) ; POW Confinement Location
S VAL=$$GET1^DIQ(2,DFN_",",.527,"I") D SET(.VPSARR,2,DFN,".527",VAL) ; POW From Date
S VAL=$$GET1^DIQ(2,DFN_",",.528,"I") D SET(.VPSARR,2,DFN,".528",VAL) ; POW Through Date
S VAL=$$GET1^DIQ(2,DFN_",",.529,"I") D SET(.VPSARR,2,DFN,".529",VAL) ; POW Status Verified
QUIT
;
PH(VPSARR,DFN) ; Store PURPLE HEART
N VAL
S VAL=$$GET1^DIQ(2,DFN_",",.531,"E") D SET(.VPSARR,2,DFN,".531",VAL) ; Current PH Indicator
S VAL=$$GET1^DIQ(2,DFN_",",.532,"E") D SET(.VPSARR,2,DFN,".532",VAL) ; Current PH Status
S VAL=$$GET1^DIQ(2,DFN_",",.533,"E") D SET(.VPSARR,2,DFN,".533",VAL) ; Current PH Remarks
QUIT
;
MP(VPSARR,DFN) ; Store Missing Person
N VAL S VAL=$$GET1^DIQ(2,DFN_",",.153,"I") D SET(.VPSARR,2,DFN,.153,VAL) ; Missing Person Date
;
N WP S WP=$$GET1^DIQ(2,DFN_",",.16,"","WP") ; Missing or ineligible
N SEQ S SEQ=0 S VAL=""
F S SEQ=$O(WP(SEQ)) QUIT:'SEQ S VAL=VAL_" "_WP(SEQ)
D SET(.VPSARR,2,DFN,.16,VAL)
;
N INE S INE=$G(^DPT(DFN,"INE"))
QUIT:INE=""
S VAL=$P(INE,U,7) D SET(.VPSARR,2,DFN,".1657",VAL) ; Missing Person TWX Source
S VAL=$P(INE,U,8) D SET(.VPSARR,2,DFN,".1658",VAL) ; Missing Person TWX City
S VAL=$P(INE,U,9) D SET(.VPSARR,2,DFN,".1659",VAL) ; Missing Person TWX State
QUIT
;
SVC(VPSARR,DFN) ; Store Service Connected and Rated Disabilities
N VAL
S VAL=$$GET1^DIQ(2,DFN_",",.3012,"I") D SET(.VPSARR,2,DFN,.3012,VAL) ; SC Award Date
S VAL=$$GET1^DIQ(2,DFN_",",.3014,"I") D SET(.VPSARR,2,DFN,.3014,VAL) ; Effective Date Combine SC% EVAL
;
N DGARR S VAL=$$RDIS^DGRPDB(DFN,.DGARR)
N SEQ S SEQ=0
F S SEQ=$O(DGARR(SEQ)) QUIT:'SEQ D
. S VAL=$P(DGARR(SEQ),U,2) D SET(.VPSARR,2.04,DFN,2,VAL) ; Disability %
. S VAL=$P(DGARR(SEQ),U,3),VAL=$S(VAL=1:"YES",1:"NO") D SET(.VPSARR,2.04,DFN,3,VAL) ; Service Connected
. S VAL=$P(DGARR(SEQ),U,4),VAL=$$GETXAFF(VAL) D SET(.VPSARR,2.04,DFN,4,VAL) ; Extremity Affected
. S VAL=$P(DGARR(SEQ),U,5) D SET(.VPSARR,2.04,DFN,5,VAL) ; Original Effective Date
. S VAL=$P(DGARR(SEQ),U,6) D SET(.VPSARR,2.04,DFN,6,VAL) ; Current Effective Date
;
;Flags/Environment Indicators
S VAL=$$GET1^DIQ(2,DFN_",",.32102,"E") D SET(.VPSARR,2,DFN,.32102,VAL) ; Agent Orange Exposure Indicated
S VAL=$$GET1^DIQ(2,DFN_",",.32107,"I") D SET(.VPSARR,2,DFN,.32107,VAL) ; Agent Orange Registration Date
S VAL=$$GET1^DIQ(2,DFN_",",.32109,"I") D SET(.VPSARR,2,DFN,.32109,VAL) ; Agent Orange Examination Date
S VAL=$$GET1^DIQ(2,DFN_",",.32103,"E") D SET(.VPSARR,2,DFN,.32103,VAL) ; Radiation Exposure Indicated
S VAL=$$GET1^DIQ(2,DFN_",",.32111,"E") D SET(.VPSARR,2,DFN,.32111,VAL) ; Radiation Registration Date
S VAL=$$GET1^DIQ(2,DFN_",",.3212,"E") D SET(.VPSARR,2,DFN,.3212,VAL) ; Radiation Exposure Method
S VAL=$$GETSHAD^DGUTL3(DFN),VAL=$S(VAL=1:"YES",1:"NO") D SET(.VPSARR,2,DFN,.32115,VAL) ; Proj 112/shad
S VAL=$$GET1^DIQ(2,DFN_",",.5291,"E") D SET(.VPSARR,2,DFN,.5291,VAL) ; Combat Service Indicated
S VAL=$$GET1^DIQ(2,DFN_",",.5293,"I") D SET(.VPSARR,2,DFN,.5293,VAL) ; Combat from date
S VAL=$$GET1^DIQ(2,DFN_",",.5294,"I") D SET(.VPSARR,2,DFN,.5294,VAL) ; Combat to Date
QUIT
;
GETXAFF(VAL) ; Get external value of Extremity Affected
QUIT:VAL="BL" "BOTH LOWER"
QUIT:VAL="BU" "BOTH UPPER"
QUIT:VAL="RL" "RIGHT LOWER"
QUIT:VAL="RU" "RIGHT UPPER"
QUIT:VAL="LL" "LEFT LOWER"
QUIT:VAL="LU" "LEFT UPPER"
QUIT ""
;
CHG(VPSARR,DFN) ; Store Change DT/TM fields
N VAL
S VAL=$$GET1^DIQ(2,DFN_",",.118,"I") D SET(.VPSARR,2,DFN,".118",VAL) ;Address Change DT/TM
S VAL=$$GET1^DIQ(2,DFN_",",.12113,"I") D SET(.VPSARR,2,DFN,".12113",VAL) ;Temp Address Change DT/TM
S VAL=$$GET1^DIQ(2,DFN_",",.14112,"I") D SET(.VPSARR,2,DFN,".14112",VAL) ; CONFIDENTIAL ADDRESS CHANGE DT/TM
S VAL=$$GET1^DIQ(2,DFN_",",.1312,"I") D SET(.VPSARR,2,DFN,".1312",VAL) ; Pager Number Change DT/TM
S VAL=$$GET1^DIQ(2,DFN_",",.136,"I") D SET(.VPSARR,2,DFN,".136",VAL) ; Email Address Change DT/TM
S VAL=$$GET1^DIQ(2,DFN_",",.139,"I") D SET(.VPSARR,2,DFN,".139",VAL) ; CELLULAR NUMBER CHANGE DATE/TIME
S VAL=$$GET1^DIQ(2,DFN_",",.33012,"I") D SET(.VPSARR,2,DFN,".33012",VAL) ; E-Contact Change DT/TM
S VAL=$$GET1^DIQ(2,DFN_",",.33112,"I") D SET(.VPSARR,2,DFN,".33112",VAL) ; E2-Contact Change DT/TM
S VAL=$$GET1^DIQ(2,DFN_",",.3412,"I") D SET(.VPSARR,2,DFN,".3412",VAL) ; Designee Change DT/TM
S VAL=$$GET1^DIQ(2,DFN_",",.21012,"I") D SET(.VPSARR,2,DFN,".21012",VAL) ; PRIMARY NOK CHANGE DATE/TIME
S VAL=$$GET1^DIQ(2,DFN_",",.211012,"I") D SET(.VPSARR,2,DFN,".211012",VAL) ; SECONDARY NOK CHANGE DATE/TIME
QUIT
;
BLPAT(VPSARR,DFN) ; Store Billing Patient
N BP S BP=+$$RXST^IBARXEU(DFN)
QUIT:BP=-1
N VAL S VAL=$S(BP=0:"NON-EXEMPT",1:"EXEMPT") D SET(.VPSARR,354,DFN,"RX COPAY",VAL) ; COPAY INCOME EXEMPTION STATUS-
;N VAL S VAL=$S(BP=0:"NON-EXEMPT",1:"EXEMPT") D SET(.VPSARR,354,DFN,"COMPUTED",VAL) ; COPAY INCOME EXEMPTION STATUS
D SET(.VPSARR,408.31,DFN,".03",$P($$LST^EASECU(DFN),U,3)) ;"LTC CO-PAY"
QUIT
;
PCT(VPSARR,DFN) ; Primary Care Team
N PCTLST D PCDETAIL^ORWPT1(.PCTLST,DFN)
N REC,FLD,FLDVAL
N PROVIDER
N ILST S ILST=0
;
F S ILST=$O(PCTLST(ILST)) QUIT:'ILST D
. S REC=PCTLST(ILST)
. QUIT:'$F(REC,":")
. S FLD=$$TRIM^XLFSTR($P(REC,":"))
. S FLDVAL=$$TRIM^XLFSTR($P(REC,":",2))
. ;
. I FLD="Primary Care Team" D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE TEAM NAME")
. I FLD="Phone" D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE TEAM TELEPHONE NUMBER")
. ;
. I FLD="Primary Care Provider" S PROVIDER=1 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE PROVIDER NAME")
. I FLD="Analog Pager",$G(PROVIDER)=1 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE PROVIDER ANALOG PAGER")
. I FLD="Digital Pager",$G(PROVIDER)=1 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE PROVIDER DIGITAL PAGER")
. I FLD="Office Phone",$G(PROVIDER)=1 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE PROVIDER OFFICE PHONE")
. ;
. I FLD="Associate Provider" S PROVIDER=2 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ASSOCIATE PROVIDER NAME")
. I FLD="Analog Pager",$G(PROVIDER)=2 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ASSOCIATE PROVIDER ANALOG PAGER")
. I FLD="Digital Pager",$G(PROVIDER)=2 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ASSOCIATE PROVIDER DIGITAL PAGER")
. I FLD="Office Phone",$G(PROVIDER)=2 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ASSOCIATE PROVIDER OFFICE PHONE")
. ;
. I FLD="Attending Physician" S PROVIDER=3 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ATTENDING PHYSICIAN NAME")
. I FLD="Analog Pager",$G(PROVIDER)=3 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ATTENDING PHYSICIAN ANALOG PAGER")
. I FLD="Digital Pager",$G(PROVIDER)=3 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ATTENDING PHYSICIAN DIGITAL PAGER")
. I FLD="Office Phone",$G(PROVIDER)=3 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ATTENDING PHYSICIAN OFFICE PHONE")
. ;
. I FLD="MH Treatment Team" S PROVIDER=4 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH TEAM")
. I FLD="MH Treatment Coordinator" S PROVIDER=4 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH COORDINATOR")
. I FLD="Analog Pager",$G(PROVIDER)=4 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH PROVIDER ANALOG PAGER")
. I FLD="Digital Pager",$G(PROVIDER)=4 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH PROVIDER DIGITAL PAGER")
. I FLD="Office Phone",$G(PROVIDER)=4 D SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH PROVIDER OFFICE PHONE")
QUIT
;
SET(VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,VPSDS) ;Set line item to output array
I VPSDA'="" D SET^VPSRPC1(.VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,$G(VPSDS),6) ;Set line item to output array
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPSRPC26 11725 printed Sep 23, 2025@20:19:53 Page 2
VPSRPC26 ;BPOIFO/EL,SLOIFO/BT - Patient Demographic (continue);07/31/14 13:07
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**4,14**;Jul 31, 2014;Build 26
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External Reference DBIA#
+5 ; ------------------------
+6 ; #2056 - DIQ call (Supported)
+7 ; #2701 - MPIF001 call (Supported)
+8 ; #3860 - DGPFAPI call (Controlled Sub)
+9 ; #4289 - PRCAHV call (Controlled Sub)
+10 ; #4419 - IBBAPI call (Supported)
+11 ; #4425 - ^DGS( references (Controlled Sub)
+12 ; #4462 - $$GETSHAD^DGUTL3 (Supported)
+13 ; #4499 - $$LST^EASECU (Controlled Sub)
+14 ; #4807 - $$RDIS^DGRPDB (Supported)
+15 ; #6107 - PCDETAIL^ORWPT1 call (Controlled Sub)
+16 ; #10035 - ^DPT( references (Supported)
+17 ; #10103 - XLFDT call (Supported)
+18 ; #10147 - $$RXST^IBARXEU (Supported)
+19 QUIT
+20 ;
IBB(VPSARR,DFN) ; Insurance Info
+1 NEW VPSIBB,VPSIBFLD
SET VPSIBFLD="1,10,11,13,14,21"
+2 NEW VAL
SET VAL=$$INSUR^IBBAPI(DFN,,"ABR",.VPSIBB,VPSIBFLD)
+3 if VAL'>0
QUIT
+4 ;
+5 NEW VPSFL,VPSIEN
+6 NEW SEQ
SET SEQ=""
+7 ;
+8 FOR
SET SEQ=$ORDER(VPSIBB("IBBAPI","INSUR",SEQ))
if SEQ=""
QUIT
Begin DoDot:1
+9 SET VPSFL="2.312"
SET VPSIEN=DFN_";"_SEQ
+10 ; Insurance Company Name
+11 SET VAL=$GET(VPSIBB("IBBAPI","INSUR",SEQ,1))
+12 SET VAL=$PIECE(VAL,U,2)
DO SET(.VPSARR,36,VPSIEN,.01,VAL)
+13 ; Policy Effective Date
+14 SET VAL=$GET(VPSIBB("IBBAPI","INSUR",SEQ,10))
+15 DO SET(.VPSARR,VPSFL,VPSIEN,8,VAL)
+16 ; Policy Expiration Date
+17 SET VAL=$GET(VPSIBB("IBBAPI","INSUR",SEQ,11))
+18 DO SET(.VPSARR,VPSFL,VPSIEN,3,VAL)
+19 ; Subscribe Name
+20 SET VAL=$GET(VPSIBB("IBBAPI","INSUR",SEQ,13))
+21 DO SET(.VPSARR,VPSFL,VPSIEN,17,VAL)
+22 ; Subscribe ID
+23 SET VAL=$GET(VPSIBB("IBBAPI","INSUR",SEQ,14))
+24 DO SET(.VPSARR,VPSFL,VPSIEN,1,VAL)
End DoDot:1
+25 ;
+26 QUIT
+27 ;
REC(VPSARR,DFN) ; Patient Record Flag
+1 NEW PRF,NPRF,PRFFIL,PRFLAG,VAL
+2 ;Retrieve all ACTIVE Patient record flag assignments
SET NPRF=$$GETACT^DGPFAPI(DFN,"VPSREC")
+3 ;
+4 ; Store all Patient Record Flags and Assigment Narratives into result array (VPSARR)
+5 FOR PRF=1:1:NPRF
Begin DoDot:1
+6 ;store flag type
+7 SET VAL=$PIECE(VPSREC(PRF,"FLAGTYPE"),U,2)
+8 SET PRFLAG=$PIECE(VPSREC(PRF,"FLAG"),U)
+9 IF VAL'=""
IF PRFLAG'=""
Begin DoDot:2
+10 SET PRFFIL=$PIECE($PIECE(PRFLAG,"DGPF(",2),",")
+11 IF PRFFIL'=""
DO SET(.VPSARR,PRFFIL,DFN,".03",VAL,"FLAG TYPE")
End DoDot:2
+12 ;store flag name
+13 SET VAL=$PIECE(VPSREC(PRF,"FLAG"),U,2)
DO SET(.VPSARR,"26.13",DFN,".02",VAL)
+14 ; Store ASSIGNMENT NARRATIVE (word-processing) for this counter
DO STNARR(PRF,.VPSREC)
End DoDot:1
+15 ;
+16 QUIT
+17 ;
STNARR(PRF,VPSREC) ; Store ASSIGNMENT NARRATIVE (word-processing) into result array (VPSARR)
+1 NEW VAL,NARRCNT
SET NARRCNT=""
+2 FOR
SET NARRCNT=$ORDER(VPSREC(PRF,"NARR",NARRCNT))
if NARRCNT=""
QUIT
Begin DoDot:1
+3 SET VAL=$GET(VPSREC(PRF,"NARR",NARRCNT,0))
DO SET(.VPSARR,"26.132",DFN,".01",VAL)
End DoDot:1
+4 QUIT
+5 ;
DGS(VPSARR,DFN) ; Pre-Registration Audit
+1 NEW VPSFL
SET VPSFL="41.41"
+2 NEW DGIEN
SET DGIEN=$ORDER(^DGS(VPSFL,"ADC",DFN,""),-1)
+3 DO SET(.VPSARR,VPSFL,DFN,1,DGIEN)
+4 QUIT
+5 ;
BAL(VPSARR,DFN) ; BALANCE-OWED
+1 NEW VPSICN
SET VPSICN=$$GETICN^MPIF001(DFN)
+2 NEW ICN
SET ICN=$PIECE(VPSICN,"V")
+3 NEW VAL,BAL
SET BAL=$$BALANCE^PRCAHV(.VAL,ICN,"ALL")
+4 IF BAL=1
DO SET(.VPSARR,430,DFN,"COMPUTED",VAL,"BALANCE")
+5 QUIT
+6 ;
OTH(VPSARR,DFN) ; Other info not in known category
+1 NEW VAL
+2 ;Period of Service
SET VAL=$$GET1^DIQ(2,DFN_",",.323,"E")
DO SET(.VPSARR,2,DFN,.323,VAL)
+3 ; Fugitive Felon Flag
SET VAL=$$GET1^DIQ(2,DFN_",",1100.01,"E")
DO SET(.VPSARR,2,DFN,1100.01,VAL)
+4 ; Exclude From Facility DIRECTORY?
SET VAL=$$GET1^DIQ(2,DFN_",",.109,"E")
DO SET(.VPSARR,2,DFN,.109,VAL)
+5 ; Laboratory Reference
SET VAL=$$GET1^DIQ(2,DFN_",",63,"E")
DO SET(.VPSARR,2,DFN,63,VAL)
+6 ; Unemployable
SET VAL=$$GET1^DIQ(2,DFN_",",.305,"E")
DO SET(.VPSARR,2,DFN,.305,VAL)
+7 QUIT
+8 ;
POW(VPSARR,DFN) ; POW information
+1 NEW VAL
+2 ; POW Status Indicated?
SET VAL=$$GET1^DIQ(2,DFN_",",.525,"E")
DO SET(.VPSARR,2,DFN,".525",VAL)
+3 ; POW Confinement Location
SET VAL=$$GET1^DIQ(2,DFN_",",.526,"E")
DO SET(.VPSARR,2,DFN,".526",VAL)
+4 ; POW From Date
SET VAL=$$GET1^DIQ(2,DFN_",",.527,"I")
DO SET(.VPSARR,2,DFN,".527",VAL)
+5 ; POW Through Date
SET VAL=$$GET1^DIQ(2,DFN_",",.528,"I")
DO SET(.VPSARR,2,DFN,".528",VAL)
+6 ; POW Status Verified
SET VAL=$$GET1^DIQ(2,DFN_",",.529,"I")
DO SET(.VPSARR,2,DFN,".529",VAL)
+7 QUIT
+8 ;
PH(VPSARR,DFN) ; Store PURPLE HEART
+1 NEW VAL
+2 ; Current PH Indicator
SET VAL=$$GET1^DIQ(2,DFN_",",.531,"E")
DO SET(.VPSARR,2,DFN,".531",VAL)
+3 ; Current PH Status
SET VAL=$$GET1^DIQ(2,DFN_",",.532,"E")
DO SET(.VPSARR,2,DFN,".532",VAL)
+4 ; Current PH Remarks
SET VAL=$$GET1^DIQ(2,DFN_",",.533,"E")
DO SET(.VPSARR,2,DFN,".533",VAL)
+5 QUIT
+6 ;
MP(VPSARR,DFN) ; Store Missing Person
+1 ; Missing Person Date
NEW VAL
SET VAL=$$GET1^DIQ(2,DFN_",",.153,"I")
DO SET(.VPSARR,2,DFN,.153,VAL)
+2 ;
+3 ; Missing or ineligible
NEW WP
SET WP=$$GET1^DIQ(2,DFN_",",.16,"","WP")
+4 NEW SEQ
SET SEQ=0
SET VAL=""
+5 FOR
SET SEQ=$ORDER(WP(SEQ))
if 'SEQ
QUIT
SET VAL=VAL_" "_WP(SEQ)
+6 DO SET(.VPSARR,2,DFN,.16,VAL)
+7 ;
+8 NEW INE
SET INE=$GET(^DPT(DFN,"INE"))
+9 if INE=""
QUIT
+10 ; Missing Person TWX Source
SET VAL=$PIECE(INE,U,7)
DO SET(.VPSARR,2,DFN,".1657",VAL)
+11 ; Missing Person TWX City
SET VAL=$PIECE(INE,U,8)
DO SET(.VPSARR,2,DFN,".1658",VAL)
+12 ; Missing Person TWX State
SET VAL=$PIECE(INE,U,9)
DO SET(.VPSARR,2,DFN,".1659",VAL)
+13 QUIT
+14 ;
SVC(VPSARR,DFN) ; Store Service Connected and Rated Disabilities
+1 NEW VAL
+2 ; SC Award Date
SET VAL=$$GET1^DIQ(2,DFN_",",.3012,"I")
DO SET(.VPSARR,2,DFN,.3012,VAL)
+3 ; Effective Date Combine SC% EVAL
SET VAL=$$GET1^DIQ(2,DFN_",",.3014,"I")
DO SET(.VPSARR,2,DFN,.3014,VAL)
+4 ;
+5 NEW DGARR
SET VAL=$$RDIS^DGRPDB(DFN,.DGARR)
+6 NEW SEQ
SET SEQ=0
+7 FOR
SET SEQ=$ORDER(DGARR(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+8 ; Disability %
SET VAL=$PIECE(DGARR(SEQ),U,2)
DO SET(.VPSARR,2.04,DFN,2,VAL)
+9 ; Service Connected
SET VAL=$PIECE(DGARR(SEQ),U,3)
SET VAL=$SELECT(VAL=1:"YES",1:"NO")
DO SET(.VPSARR,2.04,DFN,3,VAL)
+10 ; Extremity Affected
SET VAL=$PIECE(DGARR(SEQ),U,4)
SET VAL=$$GETXAFF(VAL)
DO SET(.VPSARR,2.04,DFN,4,VAL)
+11 ; Original Effective Date
SET VAL=$PIECE(DGARR(SEQ),U,5)
DO SET(.VPSARR,2.04,DFN,5,VAL)
+12 ; Current Effective Date
SET VAL=$PIECE(DGARR(SEQ),U,6)
DO SET(.VPSARR,2.04,DFN,6,VAL)
End DoDot:1
+13 ;
+14 ;Flags/Environment Indicators
+15 ; Agent Orange Exposure Indicated
SET VAL=$$GET1^DIQ(2,DFN_",",.32102,"E")
DO SET(.VPSARR,2,DFN,.32102,VAL)
+16 ; Agent Orange Registration Date
SET VAL=$$GET1^DIQ(2,DFN_",",.32107,"I")
DO SET(.VPSARR,2,DFN,.32107,VAL)
+17 ; Agent Orange Examination Date
SET VAL=$$GET1^DIQ(2,DFN_",",.32109,"I")
DO SET(.VPSARR,2,DFN,.32109,VAL)
+18 ; Radiation Exposure Indicated
SET VAL=$$GET1^DIQ(2,DFN_",",.32103,"E")
DO SET(.VPSARR,2,DFN,.32103,VAL)
+19 ; Radiation Registration Date
SET VAL=$$GET1^DIQ(2,DFN_",",.32111,"E")
DO SET(.VPSARR,2,DFN,.32111,VAL)
+20 ; Radiation Exposure Method
SET VAL=$$GET1^DIQ(2,DFN_",",.3212,"E")
DO SET(.VPSARR,2,DFN,.3212,VAL)
+21 ; Proj 112/shad
SET VAL=$$GETSHAD^DGUTL3(DFN)
SET VAL=$SELECT(VAL=1:"YES",1:"NO")
DO SET(.VPSARR,2,DFN,.32115,VAL)
+22 ; Combat Service Indicated
SET VAL=$$GET1^DIQ(2,DFN_",",.5291,"E")
DO SET(.VPSARR,2,DFN,.5291,VAL)
+23 ; Combat from date
SET VAL=$$GET1^DIQ(2,DFN_",",.5293,"I")
DO SET(.VPSARR,2,DFN,.5293,VAL)
+24 ; Combat to Date
SET VAL=$$GET1^DIQ(2,DFN_",",.5294,"I")
DO SET(.VPSARR,2,DFN,.5294,VAL)
+25 QUIT
+26 ;
GETXAFF(VAL) ; Get external value of Extremity Affected
+1 if VAL="BL"
QUIT "BOTH LOWER"
+2 if VAL="BU"
QUIT "BOTH UPPER"
+3 if VAL="RL"
QUIT "RIGHT LOWER"
+4 if VAL="RU"
QUIT "RIGHT UPPER"
+5 if VAL="LL"
QUIT "LEFT LOWER"
+6 if VAL="LU"
QUIT "LEFT UPPER"
+7 QUIT ""
+8 ;
CHG(VPSARR,DFN) ; Store Change DT/TM fields
+1 NEW VAL
+2 ;Address Change DT/TM
SET VAL=$$GET1^DIQ(2,DFN_",",.118,"I")
DO SET(.VPSARR,2,DFN,".118",VAL)
+3 ;Temp Address Change DT/TM
SET VAL=$$GET1^DIQ(2,DFN_",",.12113,"I")
DO SET(.VPSARR,2,DFN,".12113",VAL)
+4 ; CONFIDENTIAL ADDRESS CHANGE DT/TM
SET VAL=$$GET1^DIQ(2,DFN_",",.14112,"I")
DO SET(.VPSARR,2,DFN,".14112",VAL)
+5 ; Pager Number Change DT/TM
SET VAL=$$GET1^DIQ(2,DFN_",",.1312,"I")
DO SET(.VPSARR,2,DFN,".1312",VAL)
+6 ; Email Address Change DT/TM
SET VAL=$$GET1^DIQ(2,DFN_",",.136,"I")
DO SET(.VPSARR,2,DFN,".136",VAL)
+7 ; CELLULAR NUMBER CHANGE DATE/TIME
SET VAL=$$GET1^DIQ(2,DFN_",",.139,"I")
DO SET(.VPSARR,2,DFN,".139",VAL)
+8 ; E-Contact Change DT/TM
SET VAL=$$GET1^DIQ(2,DFN_",",.33012,"I")
DO SET(.VPSARR,2,DFN,".33012",VAL)
+9 ; E2-Contact Change DT/TM
SET VAL=$$GET1^DIQ(2,DFN_",",.33112,"I")
DO SET(.VPSARR,2,DFN,".33112",VAL)
+10 ; Designee Change DT/TM
SET VAL=$$GET1^DIQ(2,DFN_",",.3412,"I")
DO SET(.VPSARR,2,DFN,".3412",VAL)
+11 ; PRIMARY NOK CHANGE DATE/TIME
SET VAL=$$GET1^DIQ(2,DFN_",",.21012,"I")
DO SET(.VPSARR,2,DFN,".21012",VAL)
+12 ; SECONDARY NOK CHANGE DATE/TIME
SET VAL=$$GET1^DIQ(2,DFN_",",.211012,"I")
DO SET(.VPSARR,2,DFN,".211012",VAL)
+13 QUIT
+14 ;
BLPAT(VPSARR,DFN) ; Store Billing Patient
+1 NEW BP
SET BP=+$$RXST^IBARXEU(DFN)
+2 if BP=-1
QUIT
+3 ; COPAY INCOME EXEMPTION STATUS-
NEW VAL
SET VAL=$SELECT(BP=0:"NON-EXEMPT",1:"EXEMPT")
DO SET(.VPSARR,354,DFN,"RX COPAY",VAL)
+4 ;N VAL S VAL=$S(BP=0:"NON-EXEMPT",1:"EXEMPT") D SET(.VPSARR,354,DFN,"COMPUTED",VAL) ; COPAY INCOME EXEMPTION STATUS
+5 ;"LTC CO-PAY"
DO SET(.VPSARR,408.31,DFN,".03",$PIECE($$LST^EASECU(DFN),U,3))
+6 QUIT
+7 ;
PCT(VPSARR,DFN) ; Primary Care Team
+1 NEW PCTLST
DO PCDETAIL^ORWPT1(.PCTLST,DFN)
+2 NEW REC,FLD,FLDVAL
+3 NEW PROVIDER
+4 NEW ILST
SET ILST=0
+5 ;
+6 FOR
SET ILST=$ORDER(PCTLST(ILST))
if 'ILST
QUIT
Begin DoDot:1
+7 SET REC=PCTLST(ILST)
+8 if '$FIND(REC,"
QUIT
+9 SET FLD=$$TRIM^XLFSTR($PIECE(REC,":"))
+10 SET FLDVAL=$$TRIM^XLFSTR($PIECE(REC,":",2))
+11 ;
+12 IF FLD="Primary Care Team"
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE TEAM NAME")
+13 IF FLD="Phone"
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE TEAM TELEPHONE NUMBER")
+14 ;
+15 IF FLD="Primary Care Provider"
SET PROVIDER=1
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE PROVIDER NAME")
+16 IF FLD="Analog Pager"
IF $GET(PROVIDER)=1
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE PROVIDER ANALOG PAGER")
+17 IF FLD="Digital Pager"
IF $GET(PROVIDER)=1
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE PROVIDER DIGITAL PAGER")
+18 IF FLD="Office Phone"
IF $GET(PROVIDER)=1
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE PROVIDER OFFICE PHONE")
+19 ;
+20 IF FLD="Associate Provider"
SET PROVIDER=2
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ASSOCIATE PROVIDER NAME")
+21 IF FLD="Analog Pager"
IF $GET(PROVIDER)=2
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ASSOCIATE PROVIDER ANALOG PAGER")
+22 IF FLD="Digital Pager"
IF $GET(PROVIDER)=2
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ASSOCIATE PROVIDER DIGITAL PAGER")
+23 IF FLD="Office Phone"
IF $GET(PROVIDER)=2
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ASSOCIATE PROVIDER OFFICE PHONE")
+24 ;
+25 IF FLD="Attending Physician"
SET PROVIDER=3
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ATTENDING PHYSICIAN NAME")
+26 IF FLD="Analog Pager"
IF $GET(PROVIDER)=3
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ATTENDING PHYSICIAN ANALOG PAGER")
+27 IF FLD="Digital Pager"
IF $GET(PROVIDER)=3
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ATTENDING PHYSICIAN DIGITAL PAGER")
+28 IF FLD="Office Phone"
IF $GET(PROVIDER)=3
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE ATTENDING PHYSICIAN OFFICE PHONE")
+29 ;
+30 IF FLD="MH Treatment Team"
SET PROVIDER=4
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH TEAM")
+31 IF FLD="MH Treatment Coordinator"
SET PROVIDER=4
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH COORDINATOR")
+32 IF FLD="Analog Pager"
IF $GET(PROVIDER)=4
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH PROVIDER ANALOG PAGER")
+33 IF FLD="Digital Pager"
IF $GET(PROVIDER)=4
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH PROVIDER DIGITAL PAGER")
+34 IF FLD="Office Phone"
IF $GET(PROVIDER)=4
DO SET(.VPSARR,2,DFN,"COMPUTED",FLDVAL,"PRIMARY CARE MENTAL HEALTH PROVIDER OFFICE PHONE")
End DoDot:1
+35 QUIT
+36 ;
SET(VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,VPSDS) ;Set line item to output array
+1 ;Set line item to output array
IF VPSDA'=""
DO SET^VPSRPC1(.VPSARR,VPSFL,VPSIEN,VPSFLD,VPSDA,$GET(VPSDS),6)
+2 QUIT
