VPSRPC16 ;BPOIFO/EL,WOIFO/BT - Patient Demographic (continue);07/31/14 13:07
;;1.0;VA POINT OF SERVICE (KIOSKS);**4,14,20**;Jul 31, 2014;Build 29
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External Reference DBIA#
; ------------------------
; #10035 - ^DPT( references (Supported)
; #2462 - ^DGEN( reference (Controlled Sub)
; #2056 - DIQ call (Supported)
; #3402 - PTSEC^DGSEC4 call (Supported)
; #3403 - NOTICE^DGSEC4 call (Supported)
; #3812 - GET^DGENA (Controlled Subs)
; #2701 - MPIF001 call (Supported)
; #10061 - VADPT call (Supported)
; #10103 - XLFDT call (Supported)
; #6098 - Read-Only access to ^DGMT(408.31,"C",DFN) and FIELD HARDSHIP (Controlled Sub)
QUIT
;
GETDEM(VPSARR,DFN) ;given DFN, returns the patient demographics, insurance, and up-coming appointments.
; OUTPUT
; VPSARR - passed in by reference; this is the output array to store patient demographics
; INPUT
; DFN - patient DFN (This value must be validated before calling this procedure)
;
D DEM(.VPSARR,DFN) ; Store Patient Demographic Data
D SENLOG(.VPSARR,DFN) ; Store Patient Sensitive Record File-38.1
D ELIG(.VPSARR,DFN) ; Store Patient Eligibily
;D ENR(.VPSARR,DFN) ; Store Patient Enrollment
N X,Y
S X="",X=$O(^DGEN(27.11,"C",DFN,X),-1) Q:$G(X)=""
S Y="",Y=$$GET1^DIQ(27.11,X_",",.04,"E")
I $G(Y)'="" D SET(.VPSARR,27.11,DFN,".04",Y)
D ADD(.VPSARR,DFN) ; Store Patient Address
D OAD(.VPSARR,DFN) ; Store Other Patient Variables
D INP(.VPSARR,DFN) ; Inpatient information
D IBB^VPSRPC26(.VPSARR,DFN) ; Store Patient Insurance Info
D REC^VPSRPC26(.VPSARR,DFN) ; Store Patient Record Flag
D DGS^VPSRPC26(.VPSARR,DFN) ; Store Pre-Registration Audit
D BAL^VPSRPC26(.VPSARR,DFN) ; Store Balance
;D OTH^VPSRPC26(.VPSARR,DFN) ; Store Other information not in KNOWN API
;D POW^VPSRPC26(.VPSARR,DFN) ; Store POW
;D PH^VPSRPC26(.VPSARR,DFN) ; Store Purple Heart
;D MP^VPSRPC26(.VPSARR,DFN) ; Store Missing Person
;D SVC^VPSRPC26(.VPSARR,DFN) ; Store Service Connected and Rated Disabilities
;D CHG^VPSRPC26(.VPSARR,DFN) ; Store Change DT/TM
;D BLPAT^VPSRPC26(.VPSARR,DFN) ; Store Billing Patient
;D PCT^VPSRPC26(.VPSARR,DFN) ; Primary Care Team
Q
;
DEM(VPSARR,DFN) ; Store Patient Demographic Data
; -- Store patient DFN
D SET(.VPSARR,2,DFN,".001",DFN,"DFN")
;
; -- Store Patient ICN if exist
N VPSICN S VPSICN=$$GETICN^MPIF001(DFN)
N ICN S ICN=VPSICN
;Added above line commented out below line after VPS*1.0*20
;N ICN S ICN=$P(VPSICN,"V")
I $G(ICN)'="" D SET(.VPSARR,2,DFN,"991.01",ICN)
;
; -- Retrieve patient demographics data
N VADM D DEM^VADPT
;
; -- Store patient demographics
N VAL
S VAL=$G(VADM(1)) D SET(.VPSARR,2,DFN,".01",VAL) ; patient name
S VAL=$P($G(VADM(2)),U) D SET(.VPSARR,2,DFN,".09",VAL) ; SSN
S VAL=$P($G(VADM(3)),U) D SET(.VPSARR,2,DFN,".03",VAL) ; DOB - kiosk needs internal (FM) format for all dates
S VAL=$P($G(VADM(5)),U,2) D SET(.VPSARR,2,DFN,".02",VAL) ; SEX
S VAL=$P($G(VADM(9)),U,2) D SET(.VPSARR,2,DFN,".08",VAL)
S VAL=$P($G(VADM(10)),U,2) D SET(.VPSARR,2,DFN,".05",VAL)
;
; -- Store patient ethnicity
N SEQ,VPSFL,VPSIEN
;
I $G(VADM(11))'="" D
. N VPSFL S VPSFL="2.06",SEQ=""
. F S SEQ=$O(VADM(11,SEQ)) QUIT:SEQ="" D
. . S VAL=$P(VADM(11,SEQ),U,2)
. . S VPSIEN=DFN_";"_SEQ D SET(.VPSARR,VPSFL,VPSIEN,".01",VAL)
;
; -- Store patient race
I $G(VADM(12))'="" D
. S VPSFL="2.02",SEQ=""
. F S SEQ=$O(VADM(12,SEQ)) QUIT:SEQ="" D
. . S VAL=$P(VADM(12,SEQ),U,2)
. . S VPSIEN=DFN_";"_SEQ D SET(.VPSARR,VPSFL,VPSIEN,".01",VAL)
;
QUIT
;
SENLOG(VPSARR,DFN) ; Check Patient Sensitive Record File-38.1
N DGRES
N VAL S VAL=""
N DGOPT S DGOPT=U_"VPS KIOSK-PATIENT-SELF-CHECKIN"
N DGMSG S DGMSG=1
D PTSEC^DGSEC4(.DGRES,DFN,DGMSG,DGOPT)
N RES S RES=$G(DGRES(1))
;
I RES=2 D QUIT
. N ACTION S ACTION=1
. D NOTICE^DGSEC4(.DGRES,DFN,DGOPT,ACTION)
. S VAL="2;SENSITIVE & SEC-AUDIT LOG & KIOSK MACHINE LOGIN-DUZ HOLDING NOSECURITY KEY"
. D SET(.VPSARR,38.1,DFN,"IA3403",VAL,"SENSITIVE")
;
S:RES=0 VAL="0;NON-SENSITIVE"
S:RES=1 VAL="1;SENSITIVE & SEC-AUDIT LOG & KIOSK MACHINE LOGIN-DUZ HOLDING SECURITY KEY"
S:RES=3 VAL="3;CANNOT CHECK SENSITIVE DUE TO KIOSK MACHINE LOGIN-DUZ ACCESSING OWN RECORD"
S:RES=4 VAL="4;CANNOT CHECK SENSITIVE DUE TO KIOSK MACHINE LOGIN-DUZ MISSING SSN"
S:VAL="" VAL="-1;MISSING DFN IN SENSITIVE CHECK"
D SET(.VPSARR,38.1,DFN,"IA3402",VAL,"SENSITIVE")
;
QUIT
;
ELIG(VPSARR,DFN) ; Eligibily
N VAEL D ELIG^VADPT
N VAL
S VAL=$P($G(VAEL(6)),U,2) D SET(.VPSARR,2,DFN,391,VAL) ; Patient Type
S VAL=$$GET1^DIQ(2,DFN_",",.381,"E") D SET(.VPSARR,2,DFN,.381,VAL) ;Eligibility for Medicare
;
; --- Primary Eligibility Code
N PELIG S PELIG=$P($G(VAEL(1)),U)
S VAL=$P($G(VAEL(1)),U,2) D SET(.VPSARR,2,DFN,.361,VAL)
;
S VAL=$P($G(VAEL(5,1)),U) D SET(.VPSARR,2,DFN,.152,VAL) ;InEligible Date
S VAL=$P($G(VAEL(8)),U,2) D SET(.VPSARR,2,DFN,.3611,VAL) ;Eligibility Status
S VAL=$$GET1^DIQ(2,DFN_",",.3612,"I") D SET(.VPSARR,2,DFN,.3612,VAL) ; Eligibility Status Date
S VAL=$P($G(VAEL(9)),U,2) D SET(.VPSARR,2,DFN,.14,VAL) ; Means Test Status
;
; --- Secondary Eligibility codes
N ELIG,ELIGNAM S ELIG=0
F S ELIG=$O(^DPT("AEL",DFN,ELIG)) Q:'ELIG D
. I ELIG'=PELIG S ELIGNAM=$$GET1^DIQ(8,ELIG_",",.01) D SET(.VPSARR,8,DFN_";"_ELIG,.01,ELIGNAM,"SECONDARY ELIGIBILITY CODE")
;
; --- Annual Mean Test
N MTIEN S MTIEN=$O(^DGMT(408.31,"C",DFN,0))
I MTIEN S VAL=$$GET1^DIQ(408.31,MTIEN_",",.2,"E") D SET(.VPSARR,408.31,DFN_";"_MTIEN,.2,VAL) ; HARDSHIP?
QUIT
;
INP(VPSARR,DFN) ;
N VAIP
D IN5^VADPT
D SET(.VPSARR,2,DFN,"",$S(VAIP(5)]"":"YES",1:"NO"),"INPATIENT STATUS") ; Inpatient Status
D SET(.VPSARR,2,DFN,.1,$P(VAIP(5),U,2),"") ; Patient Ward Location
D SET(.VPSARR,2,DFN,.101,$P(VAIP(6),U,2),"") ; Patient Bed Assignment
D SET(.VPSARR,2,DFN,.109,$P(VAIP(19,1),U,2),"") ; Facility Directory Preference
QUIT
;
ENR(VPSARR,DFN) ; Enrollment
N ENRIEN S ENRIEN=$O(^DGEN(27.11,"C",DFN,""),-1)
QUIT:ENRIEN=""
N DGENR D GET^DGENA(ENRIEN,.DGENR)
N VAL
S VAL=$G(DGENR("STATUS")),VAL=$$GET1^DIQ(27.11,ENRIEN_",",.04,"E") D SET(.VPSARR,27.11,DFN_";"_ENRIEN,.04,VAL) ;ENROLLMENT STATUS
S VAL=$G(DGENR("ELIG","CODE")),VAL=$$GET1^DIQ(27.11,ENRIEN_",",50.01,"E") D SET(.VPSARR,27.11,DFN_";"_ENRIEN,50.01,VAL) ;ELIGIBILITY CODE
S VAL=$G(DGENR("ELIG","SC")) D SET(.VPSARR,27.11,DFN_";"_ENRIEN,50.02,VAL) ;SERVICE CONNECTED
S VAL=$G(DGENR("ELIG","SCPER")) D SET(.VPSARR,27.11,DFN_";"_ENRIEN,50.03,VAL) ;SERVICE CONNECTED PERCENTAGE
S VAL=$G(DGENR("DATE")) D SET(.VPSARR,27.11,DFN_";"_ENRIEN,.1,VAL) ;ENROLLMENT DATE
S VAL=$G(DGENR("EFFDATE")) D SET(.VPSARR,27.11,DFN_";"_ENRIEN,.08,VAL) ;EFFECTIVE DATE
S VAL=$G(DGENR("PRIORITY")) D SET(.VPSARR,27.11,DFN_";"_ENRIEN,.07,VAL) ;ENROLLMENT PRIORITY
S VAL=$G(DGENR("ELIG","EC")) D SET(.VPSARR,27.11,DFN_";"_ENRIEN,50.13,VAL) ;SOUTH WEST ASIA CONDITION
;
; -- Enrollment Clinic
N ENRCLN,ENRDATE,VAL
N ECLNSEQ S ECLNSEQ=0
N EDTSEQ S EDTSEQ=0
;
F S ECLNSEQ=$O(^DPT(DFN,"DE",ECLNSEQ)) QUIT:'ECLNSEQ D
. S ENRCLN=$G(^DPT(DFN,"DE",ECLNSEQ,0)) QUIT:ENRCLN=""
. S VAL=$$GET1^DIQ(2.001,ECLNSEQ_","_DFN_",",.01,"E") ; enrollment clinic
. D SET(.VPSARR,2.001,DFN_";"_ECLNSEQ,.01,VAL)
. N VAL S VAL=$$GET1^DIQ(2.001,ECLNSEQ_","_DFN_",",2,"E") ; current status
. D SET(.VPSARR,2.001,DFN_";"_ECLNSEQ,2,VAL)
. ;
. ; -- Enrollment Data
. S EDTSEQ=0
. F S EDTSEQ=$O(^DPT(DFN,"DE",ECLNSEQ,1,EDTSEQ)) Q:'EDTSEQ D
. . S ENRDATE=$G(^DPT(DFN,"DE",ECLNSEQ,1,EDTSEQ,0)) QUIT:ENRDATE=""
. . S VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",.01,"I") ; Date of Enrollment
. . D SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,.01,VAL)
. . S VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",1,"E") ; opt or ac
. . D SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,1,VAL)
. . S VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",2,"E") ; Service
. . D SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,2,VAL)
. . S VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",3,"I") ; Date of Discharge
. . D SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,3,VAL)
. . S VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",4,"E") ; Reason of Discharge
. . D SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,4,VAL)
. . S VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",5,"I") ; Review Date
. . D SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,5,VAL)
;
QUIT
;
ADD(VPSARR,DFN) ; Addresses
N VAPA D ADD^VADPT
N VAL,TODAY S TODAY=$$DT^XLFDT()
;
S VAL=$P($G(VAPA(9)),U)
I VAL=""!(TODAY<VAL) D SETPERM(.VPSARR,DFN,.VAPA) QUIT
;
S VAL=$P($G(VAPA(10)),U)
I VAL=""!(TODAY'>VAL) D SETMP(.VPSARR,DFN,.VAPA) QUIT
;
D SETPERM(.VPSARR,DFN,.VAPA)
QUIT
;
SETPERM(VPSARR,DFN,VAPA) ; PERM ADDRESS
N VAL
S VAL=$G(VAPA(1)) D SET(.VPSARR,2,DFN,".111",VAL)
S VAL=$G(VAPA(2)) D SET(.VPSARR,2,DFN,".112",VAL)
S VAL=$G(VAPA(3)) D SET(.VPSARR,2,DFN,".113",VAL)
S VAL=$G(VAPA(4)) D SET(.VPSARR,2,DFN,".114",VAL)
S VAL=$P($G(VAPA(5)),U,2) D SET(.VPSARR,2,DFN,".115",VAL)
S VAL=$P($G(VAPA(7)),U,2) D SET(.VPSARR,2,DFN,".117",VAL)
S VAL=$G(VAPA(8)) D SET(.VPSARR,2,DFN,".131",VAL)
S VAL=$P($G(VAPA(11)),U,2) D SET(.VPSARR,2,DFN,".1112",VAL)
S VAL=$P($G(VAPA(25)),U,2) D SET(.VPSARR,2,DFN,".1173",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.1171,"E") D SET(.VPSARR,2,DFN,".1171",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.1172,"E") D SET(.VPSARR,2,DFN,".1172",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.121,"E") D SET(.VPSARR,2,DFN,".121",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.132,"E") D SET(.VPSARR,2,DFN,".132",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.134,"E") D SET(.VPSARR,2,DFN,".134",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.133,"E") D SET(.VPSARR,2,DFN,".133",VAL)
D SETCONF(.VPSARR,DFN,.VAPA)
QUIT
;
SETMP(VPSARR,DFN,VAPA) ; SET TEMP ADD
N VAL
S VAL=$G(VAPA(1)) D SET(.VPSARR,2,DFN,".1211",VAL)
S VAL=$G(VAPA(2)) D SET(.VPSARR,2,DFN,".1212",VAL)
S VAL=$G(VAPA(3)) D SET(.VPSARR,2,DFN,".1213",VAL)
S VAL=$G(VAPA(4)) D SET(.VPSARR,2,DFN,".1214",VAL)
S VAL=$P($G(VAPA(5)),U,2) D SET(.VPSARR,2,DFN,".1215",VAL)
S VAL=$P($G(VAPA(7)),U,2) D SET(.VPSARR,2,DFN,".12111",VAL)
S VAL=$G(VAPA(8)) D SET(.VPSARR,2,DFN,".1219",VAL)
S VAL=$P($G(VAPA(9)),U,2) D SET(.VPSARR,2,DFN,".1217",VAL)
S VAL=$P($G(VAPA(10)),U,2) D SET(.VPSARR,2,DFN,".1218",VAL)
S VAL=$P($G(VAPA(11)),U,2) D SET(.VPSARR,2,DFN,".12112",VAL)
S VAL=$P($G(VAPA(25)),U,2) D SET(.VPSARR,2,DFN,".1223",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.1221,"E") D SET(.VPSARR,2,DFN,".1221",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.1222,"E") D SET(.VPSARR,2,DFN,".1222",VAL)
;
K VAPA S VAPA("P")="" D ADD^VADPT
D SETPERM(.VPSARR,DFN,.VAPA)
;
QUIT
;
SETCONF(VPSARR,DFN,VAPA) ;Confindential address
N VAL
S VAL=$G(VAPA(13)) D SET(.VPSARR,2,DFN,".1411",VAL) ; CONFIDENTIAL STREET [LINE 1]
S VAL=$G(VAPA(14)) D SET(.VPSARR,2,DFN,".1412",VAL) ; CONFIDENTIAL STREET [LINE 2]
S VAL=$G(VAPA(15)) D SET(.VPSARR,2,DFN,".1413",VAL) ; CONFIDENTIAL STREET [LINE 2]
S VAL=$G(VAPA(16)) D SET(.VPSARR,2,DFN,".1414",VAL) ; CONFIDENTIAL ADDRESS CITY
S VAL=$G(VAPA(17)) S VAL=$P(VAL,U,2) D SET(.VPSARR,2,DFN,".1415",VAL) ; CONFIDENTIAL ADDRESS STATE
S VAL=$G(VAPA(18)) S VAL=$P(VAL,U,2) D SET(.VPSARR,2,DFN,".1416",VAL) ; CONFIDENTIAL ADDRESS ZIP CODE
S VAL=$G(VAPA(19)) D SET(.VPSARR,2,DFN,".14111",VAL) ; CONFIDENTIAL ADDRESS COUNTY
S VAL=$G(VAPA(20)) I +VAL D SET(.VPSARR,2,DFN,".1417",+VAL) ; CONFIDENTIAL START DATE
S VAL=$G(VAPA(21)) I +VAL D SET(.VPSARR,2,DFN,".1418",+VAL) ; CONFIDENTIAL END DATE
S VAL=$$GET1^DIQ(2,DFN_",",.14105,"E") D SET(.VPSARR,2,DFN,".14105",VAL) ; CONFIDENTIAL ADDRESS ACTIVE?
S VAL=$P($G(VAPA(28)),U,2) D SET(.VPSARR,2,DFN,".14116",VAL) ; CONFIDENTIAL ADDRESS COUNTRY
S VAL=$G(VAPA(29)) D SET(.VPSARR,2,DFN,".1315",VAL) ; CONFIDENTIAL PHONE NUMBER
;
; -- Confidential Address categories
N TYP S TYP=0
F S TYP=$O(VAPA(22,TYP)) Q:'TYP D
. S VAL=$P(VAPA(22,TYP),U,2)
. D SET(.VPSARR,2.141,DFN_";"_TYP,".01",VAL) ; CONFIDENTIAL ADDRESS CATEGORY
;
QUIT
;
OAD(VPSARR,DFN) ; Other Patient Variables
N VAL,VAOA S VAOA("A")=7 D OAD^VADPT ; NOK
S VAL=$G(VAOA(1)) D SET(.VPSARR,2,DFN,".213",VAL)
S VAL=$G(VAOA(2)) D SET(.VPSARR,2,DFN,".214",VAL)
S VAL=$G(VAOA(3)) D SET(.VPSARR,2,DFN,".215",VAL)
S VAL=$G(VAOA(4)) D SET(.VPSARR,2,DFN,".216",VAL)
S VAL=$P(VAOA(5),U,2) D SET(.VPSARR,2,DFN,".217",VAL)
S VAL=$G(VAOA(11)) S VAL=$P(VAL,U,2) D SET(.VPSARR,2,DFN,".2207",VAL)
S VAL=$G(VAOA(8)) D SET(.VPSARR,2,DFN,".219",VAL)
S VAL=$G(VAOA(9)) D SET(.VPSARR,2,DFN,".211",VAL)
S VAL=$G(VAOA(10)) D SET(.VPSARR,2,DFN,".212",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.21011,"E") D SET(.VPSARR,2,DFN,".21011",VAL)
;
K VAOA S VAOA("A")=3 D OAD^VADPT ; Second NOK
S VAL=$G(VAOA(1)) D SET(.VPSARR,2,DFN,".2193",VAL)
S VAL=$G(VAOA(2)) D SET(.VPSARR,2,DFN,".2194",VAL)
S VAL=$G(VAOA(3)) D SET(.VPSARR,2,DFN,".2195",VAL)
S VAL=$G(VAOA(4)) D SET(.VPSARR,2,DFN,".2196",VAL)
S VAL=$P($G(VAOA(5)),U,2) D SET(.VPSARR,2,DFN,".2197",VAL)
S VAL=$G(VAOA(11)) S VAL=$P(VAL,U,2) D SET(.VPSARR,2,DFN,".2203",VAL)
S VAL=$G(VAOA(8)) D SET(.VPSARR,2,DFN,".2199",VAL)
S VAL=$G(VAOA(9)) D SET(.VPSARR,2,DFN,".2191",VAL)
S VAL=$G(VAOA(10)) D SET(.VPSARR,2,DFN,".2192",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.211011,"E") D SET(.VPSARR,2,DFN,".211011",VAL)
;
K VAOA S VAOA("A")=1 D OAD^VADPT ; Emergency Contact
S VAL=$G(VAOA(1)) D SET(.VPSARR,2,DFN,".333",VAL)
S VAL=$G(VAOA(2)) D SET(.VPSARR,2,DFN,".334",VAL)
S VAL=$G(VAOA(3)) D SET(.VPSARR,2,DFN,".335",VAL)
S VAL=$G(VAOA(4)) D SET(.VPSARR,2,DFN,".336",VAL)
S VAL=$P($G(VAOA(5)),U,2) D SET(.VPSARR,2,DFN,".337",VAL)
S VAL=$P($G(VAOA(11)),U,2) D SET(.VPSARR,2,DFN,".2201",VAL)
S VAL=$G(VAOA(8)) D SET(.VPSARR,2,DFN,".339",VAL)
S VAL=$G(VAOA(9)) D SET(.VPSARR,2,DFN,".331",VAL)
S VAL=$G(VAOA(10)) D SET(.VPSARR,2,DFN,".332",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.33011,"E") D SET(.VPSARR,2,DFN,".33011",VAL)
;
K VAOA S VAOA("A")=4 D OAD^VADPT ; Second Emergency Contact
S VAL=$G(VAOA(1)) D SET(.VPSARR,2,DFN,".3313",VAL)
S VAL=$G(VAOA(2)) D SET(.VPSARR,2,DFN,".3314",VAL)
S VAL=$G(VAOA(3)) D SET(.VPSARR,2,DFN,".3315",VAL)
S VAL=$G(VAOA(4)) D SET(.VPSARR,2,DFN,".3316",VAL)
S VAL=$P($G(VAOA(5)),U,2) D SET(.VPSARR,2,DFN,".3317",VAL)
S VAL=$P($G(VAOA(11)),U,2) D SET(.VPSARR,2,DFN,".2204",VAL)
S VAL=$G(VAOA(8)) D SET(.VPSARR,2,DFN,".3319",VAL)
S VAL=$G(VAOA(9)) D SET(.VPSARR,2,DFN,".3311",VAL)
S VAL=$G(VAOA(10)) D SET(.VPSARR,2,DFN,".3312",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.331011,"E") D SET(.VPSARR,2,DFN,".331011",VAL)
;
K VAOA S VAOA("A")=5 D OAD^VADPT ; Patient Employer
S VAL=$G(VAOA(8)) D SET(.VPSARR,2,DFN,".3119",VAL)
S VAL=$G(VAOA(9)) D SET(.VPSARR,2,DFN,".3111",VAL)
;
N VAPD D OPD^VADPT
S VAL=$P($G(VAPD(7)),U,2) D SET(.VPSARR,2,DFN,".31115",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.31116,"E") D SET(.VPSARR,2,DFN,".31116",VAL)
;
K VAOA S VAOA("A")=6 D OAD^VADPT ; Spouse's Employer
S VAL=$G(VAOA(8)) D SET(.VPSARR,2,DFN,".258",VAL)
S VAL=$G(VAOA(9)) D SET(.VPSARR,2,DFN,".251",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.2515,"E") D SET(.VPSARR,2,DFN,".2515",VAL)
S VAL=$$GET1^DIQ(2,DFN_",",.2516,"E") D SET(.VPSARR,2,DFN,".2516",VAL)
;
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[HVPSRPC16 15651 printed Nov 22, 2024@17:53:23 Page 2
VPSRPC16 ;BPOIFO/EL,WOIFO/BT - Patient Demographic (continue);07/31/14 13:07
+1 ;;1.0;VA POINT OF SERVICE (KIOSKS);**4,14,20**;Jul 31, 2014;Build 29
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External Reference DBIA#
+5 ; ------------------------
+6 ; #10035 - ^DPT( references (Supported)
+7 ; #2462 - ^DGEN( reference (Controlled Sub)
+8 ; #2056 - DIQ call (Supported)
+9 ; #3402 - PTSEC^DGSEC4 call (Supported)
+10 ; #3403 - NOTICE^DGSEC4 call (Supported)
+11 ; #3812 - GET^DGENA (Controlled Subs)
+12 ; #2701 - MPIF001 call (Supported)
+13 ; #10061 - VADPT call (Supported)
+14 ; #10103 - XLFDT call (Supported)
+15 ; #6098 - Read-Only access to ^DGMT(408.31,"C",DFN) and FIELD HARDSHIP (Controlled Sub)
+16 QUIT
+17 ;
GETDEM(VPSARR,DFN) ;given DFN, returns the patient demographics, insurance, and up-coming appointments.
+1 ; OUTPUT
+2 ; VPSARR - passed in by reference; this is the output array to store patient demographics
+3 ; INPUT
+4 ; DFN - patient DFN (This value must be validated before calling this procedure)
+5 ;
+6 ; Store Patient Demographic Data
DO DEM(.VPSARR,DFN)
+7 ; Store Patient Sensitive Record File-38.1
DO SENLOG(.VPSARR,DFN)
+8 ; Store Patient Eligibily
DO ELIG(.VPSARR,DFN)
+9 ;D ENR(.VPSARR,DFN) ; Store Patient Enrollment
+10 NEW X,Y
+11 SET X=""
SET X=$ORDER(^DGEN(27.11,"C",DFN,X),-1)
if $GET(X)=""
QUIT
+12 SET Y=""
SET Y=$$GET1^DIQ(27.11,X_",",.04,"E")
+13 IF $GET(Y)'=""
DO SET(.VPSARR,27.11,DFN,".04",Y)
+14 ; Store Patient Address
DO ADD(.VPSARR,DFN)
+15 ; Store Other Patient Variables
DO OAD(.VPSARR,DFN)
+16 ; Inpatient information
DO INP(.VPSARR,DFN)
+17 ; Store Patient Insurance Info
DO IBB^VPSRPC26(.VPSARR,DFN)
+18 ; Store Patient Record Flag
DO REC^VPSRPC26(.VPSARR,DFN)
+19 ; Store Pre-Registration Audit
DO DGS^VPSRPC26(.VPSARR,DFN)
+20 ; Store Balance
DO BAL^VPSRPC26(.VPSARR,DFN)
+21 ;D OTH^VPSRPC26(.VPSARR,DFN) ; Store Other information not in KNOWN API
+22 ;D POW^VPSRPC26(.VPSARR,DFN) ; Store POW
+23 ;D PH^VPSRPC26(.VPSARR,DFN) ; Store Purple Heart
+24 ;D MP^VPSRPC26(.VPSARR,DFN) ; Store Missing Person
+25 ;D SVC^VPSRPC26(.VPSARR,DFN) ; Store Service Connected and Rated Disabilities
+26 ;D CHG^VPSRPC26(.VPSARR,DFN) ; Store Change DT/TM
+27 ;D BLPAT^VPSRPC26(.VPSARR,DFN) ; Store Billing Patient
+28 ;D PCT^VPSRPC26(.VPSARR,DFN) ; Primary Care Team
+29 QUIT
+30 ;
DEM(VPSARR,DFN) ; Store Patient Demographic Data
+1 ; -- Store patient DFN
+2 DO SET(.VPSARR,2,DFN,".001",DFN,"DFN")
+3 ;
+4 ; -- Store Patient ICN if exist
+5 NEW VPSICN
SET VPSICN=$$GETICN^MPIF001(DFN)
+6 NEW ICN
SET ICN=VPSICN
+7 ;Added above line commented out below line after VPS*1.0*20
+8 ;N ICN S ICN=$P(VPSICN,"V")
+9 IF $GET(ICN)'=""
DO SET(.VPSARR,2,DFN,"991.01",ICN)
+10 ;
+11 ; -- Retrieve patient demographics data
+12 NEW VADM
DO DEM^VADPT
+13 ;
+14 ; -- Store patient demographics
+15 NEW VAL
+16 ; patient name
SET VAL=$GET(VADM(1))
DO SET(.VPSARR,2,DFN,".01",VAL)
+17 ; SSN
SET VAL=$PIECE($GET(VADM(2)),U)
DO SET(.VPSARR,2,DFN,".09",VAL)
+18 ; DOB - kiosk needs internal (FM) format for all dates
SET VAL=$PIECE($GET(VADM(3)),U)
DO SET(.VPSARR,2,DFN,".03",VAL)
+19 ; SEX
SET VAL=$PIECE($GET(VADM(5)),U,2)
DO SET(.VPSARR,2,DFN,".02",VAL)
+20 SET VAL=$PIECE($GET(VADM(9)),U,2)
DO SET(.VPSARR,2,DFN,".08",VAL)
+21 SET VAL=$PIECE($GET(VADM(10)),U,2)
DO SET(.VPSARR,2,DFN,".05",VAL)
+22 ;
+23 ; -- Store patient ethnicity
+24 NEW SEQ,VPSFL,VPSIEN
+25 ;
+26 IF $GET(VADM(11))'=""
Begin DoDot:1
+27 NEW VPSFL
SET VPSFL="2.06"
SET SEQ=""
+28 FOR
SET SEQ=$ORDER(VADM(11,SEQ))
if SEQ=""
QUIT
Begin DoDot:2
+29 SET VAL=$PIECE(VADM(11,SEQ),U,2)
+30 SET VPSIEN=DFN_";"_SEQ
DO SET(.VPSARR,VPSFL,VPSIEN,".01",VAL)
End DoDot:2
End DoDot:1
+31 ;
+32 ; -- Store patient race
+33 IF $GET(VADM(12))'=""
Begin DoDot:1
+34 SET VPSFL="2.02"
SET SEQ=""
+35 FOR
SET SEQ=$ORDER(VADM(12,SEQ))
if SEQ=""
QUIT
Begin DoDot:2
+36 SET VAL=$PIECE(VADM(12,SEQ),U,2)
+37 SET VPSIEN=DFN_";"_SEQ
DO SET(.VPSARR,VPSFL,VPSIEN,".01",VAL)
End DoDot:2
End DoDot:1
+38 ;
+39 QUIT
+40 ;
SENLOG(VPSARR,DFN) ; Check Patient Sensitive Record File-38.1
+1 NEW DGRES
+2 NEW VAL
SET VAL=""
+3 NEW DGOPT
SET DGOPT=U_"VPS KIOSK-PATIENT-SELF-CHECKIN"
+4 NEW DGMSG
SET DGMSG=1
+5 DO PTSEC^DGSEC4(.DGRES,DFN,DGMSG,DGOPT)
+6 NEW RES
SET RES=$GET(DGRES(1))
+7 ;
+8 IF RES=2
Begin DoDot:1
+9 NEW ACTION
SET ACTION=1
+10 DO NOTICE^DGSEC4(.DGRES,DFN,DGOPT,ACTION)
+11 SET VAL="2;SENSITIVE & SEC-AUDIT LOG & KIOSK MACHINE LOGIN-DUZ HOLDING NOSECURITY KEY"
+12 DO SET(.VPSARR,38.1,DFN,"IA3403",VAL,"SENSITIVE")
End DoDot:1
QUIT
+13 ;
+14 if RES=0
SET VAL="0;NON-SENSITIVE"
+15 if RES=1
SET VAL="1;SENSITIVE & SEC-AUDIT LOG & KIOSK MACHINE LOGIN-DUZ HOLDING SECURITY KEY"
+16 if RES=3
SET VAL="3;CANNOT CHECK SENSITIVE DUE TO KIOSK MACHINE LOGIN-DUZ ACCESSING OWN RECORD"
+17 if RES=4
SET VAL="4;CANNOT CHECK SENSITIVE DUE TO KIOSK MACHINE LOGIN-DUZ MISSING SSN"
+18 if VAL=""
SET VAL="-1;MISSING DFN IN SENSITIVE CHECK"
+19 DO SET(.VPSARR,38.1,DFN,"IA3402",VAL,"SENSITIVE")
+20 ;
+21 QUIT
+22 ;
ELIG(VPSARR,DFN) ; Eligibily
+1 NEW VAEL
DO ELIG^VADPT
+2 NEW VAL
+3 ; Patient Type
SET VAL=$PIECE($GET(VAEL(6)),U,2)
DO SET(.VPSARR,2,DFN,391,VAL)
+4 ;Eligibility for Medicare
SET VAL=$$GET1^DIQ(2,DFN_",",.381,"E")
DO SET(.VPSARR,2,DFN,.381,VAL)
+5 ;
+6 ; --- Primary Eligibility Code
+7 NEW PELIG
SET PELIG=$PIECE($GET(VAEL(1)),U)
+8 SET VAL=$PIECE($GET(VAEL(1)),U,2)
DO SET(.VPSARR,2,DFN,.361,VAL)
+9 ;
+10 ;InEligible Date
SET VAL=$PIECE($GET(VAEL(5,1)),U)
DO SET(.VPSARR,2,DFN,.152,VAL)
+11 ;Eligibility Status
SET VAL=$PIECE($GET(VAEL(8)),U,2)
DO SET(.VPSARR,2,DFN,.3611,VAL)
+12 ; Eligibility Status Date
SET VAL=$$GET1^DIQ(2,DFN_",",.3612,"I")
DO SET(.VPSARR,2,DFN,.3612,VAL)
+13 ; Means Test Status
SET VAL=$PIECE($GET(VAEL(9)),U,2)
DO SET(.VPSARR,2,DFN,.14,VAL)
+14 ;
+15 ; --- Secondary Eligibility codes
+16 NEW ELIG,ELIGNAM
SET ELIG=0
+17 FOR
SET ELIG=$ORDER(^DPT("AEL",DFN,ELIG))
if 'ELIG
QUIT
Begin DoDot:1
+18 IF ELIG'=PELIG
SET ELIGNAM=$$GET1^DIQ(8,ELIG_",",.01)
DO SET(.VPSARR,8,DFN_";"_ELIG,.01,ELIGNAM,"SECONDARY ELIGIBILITY CODE")
End DoDot:1
+19 ;
+20 ; --- Annual Mean Test
+21 NEW MTIEN
SET MTIEN=$ORDER(^DGMT(408.31,"C",DFN,0))
+22 ; HARDSHIP?
IF MTIEN
SET VAL=$$GET1^DIQ(408.31,MTIEN_",",.2,"E")
DO SET(.VPSARR,408.31,DFN_";"_MTIEN,.2,VAL)
+23 QUIT
+24 ;
INP(VPSARR,DFN) ;
+1 NEW VAIP
+2 DO IN5^VADPT
+3 ; Inpatient Status
DO SET(.VPSARR,2,DFN,"",$SELECT(VAIP(5)]"":"YES",1:"NO"),"INPATIENT STATUS")
+4 ; Patient Ward Location
DO SET(.VPSARR,2,DFN,.1,$PIECE(VAIP(5),U,2),"")
+5 ; Patient Bed Assignment
DO SET(.VPSARR,2,DFN,.101,$PIECE(VAIP(6),U,2),"")
+6 ; Facility Directory Preference
DO SET(.VPSARR,2,DFN,.109,$PIECE(VAIP(19,1),U,2),"")
+7 QUIT
+8 ;
ENR(VPSARR,DFN) ; Enrollment
+1 NEW ENRIEN
SET ENRIEN=$ORDER(^DGEN(27.11,"C",DFN,""),-1)
+2 if ENRIEN=""
QUIT
+3 NEW DGENR
DO GET^DGENA(ENRIEN,.DGENR)
+4 NEW VAL
+5 ;ENROLLMENT STATUS
SET VAL=$GET(DGENR("STATUS"))
SET VAL=$$GET1^DIQ(27.11,ENRIEN_",",.04,"E")
DO SET(.VPSARR,27.11,DFN_";"_ENRIEN,.04,VAL)
+6 ;ELIGIBILITY CODE
SET VAL=$GET(DGENR("ELIG","CODE"))
SET VAL=$$GET1^DIQ(27.11,ENRIEN_",",50.01,"E")
DO SET(.VPSARR,27.11,DFN_";"_ENRIEN,50.01,VAL)
+7 ;SERVICE CONNECTED
SET VAL=$GET(DGENR("ELIG","SC"))
DO SET(.VPSARR,27.11,DFN_";"_ENRIEN,50.02,VAL)
+8 ;SERVICE CONNECTED PERCENTAGE
SET VAL=$GET(DGENR("ELIG","SCPER"))
DO SET(.VPSARR,27.11,DFN_";"_ENRIEN,50.03,VAL)
+9 ;ENROLLMENT DATE
SET VAL=$GET(DGENR("DATE"))
DO SET(.VPSARR,27.11,DFN_";"_ENRIEN,.1,VAL)
+10 ;EFFECTIVE DATE
SET VAL=$GET(DGENR("EFFDATE"))
DO SET(.VPSARR,27.11,DFN_";"_ENRIEN,.08,VAL)
+11 ;ENROLLMENT PRIORITY
SET VAL=$GET(DGENR("PRIORITY"))
DO SET(.VPSARR,27.11,DFN_";"_ENRIEN,.07,VAL)
+12 ;SOUTH WEST ASIA CONDITION
SET VAL=$GET(DGENR("ELIG","EC"))
DO SET(.VPSARR,27.11,DFN_";"_ENRIEN,50.13,VAL)
+13 ;
+14 ; -- Enrollment Clinic
+15 NEW ENRCLN,ENRDATE,VAL
+16 NEW ECLNSEQ
SET ECLNSEQ=0
+17 NEW EDTSEQ
SET EDTSEQ=0
+18 ;
+19 FOR
SET ECLNSEQ=$ORDER(^DPT(DFN,"DE",ECLNSEQ))
if 'ECLNSEQ
QUIT
Begin DoDot:1
+20 SET ENRCLN=$GET(^DPT(DFN,"DE",ECLNSEQ,0))
if ENRCLN=""
QUIT
+21 ; enrollment clinic
SET VAL=$$GET1^DIQ(2.001,ECLNSEQ_","_DFN_",",.01,"E")
+22 DO SET(.VPSARR,2.001,DFN_";"_ECLNSEQ,.01,VAL)
+23 ; current status
NEW VAL
SET VAL=$$GET1^DIQ(2.001,ECLNSEQ_","_DFN_",",2,"E")
+24 DO SET(.VPSARR,2.001,DFN_";"_ECLNSEQ,2,VAL)
+25 ;
+26 ; -- Enrollment Data
+27 SET EDTSEQ=0
+28 FOR
SET EDTSEQ=$ORDER(^DPT(DFN,"DE",ECLNSEQ,1,EDTSEQ))
if 'EDTSEQ
QUIT
Begin DoDot:2
+29 SET ENRDATE=$GET(^DPT(DFN,"DE",ECLNSEQ,1,EDTSEQ,0))
if ENRDATE=""
QUIT
+30 ; Date of Enrollment
SET VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",.01,"I")
+31 DO SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,.01,VAL)
+32 ; opt or ac
SET VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",1,"E")
+33 DO SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,1,VAL)
+34 ; Service
SET VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",2,"E")
+35 DO SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,2,VAL)
+36 ; Date of Discharge
SET VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",3,"I")
+37 DO SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,3,VAL)
+38 ; Reason of Discharge
SET VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",4,"E")
+39 DO SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,4,VAL)
+40 ; Review Date
SET VAL=$$GET1^DIQ(2.011,EDTSEQ_","_ECLNSEQ_","_DFN_",",5,"I")
+41 DO SET(.VPSARR,2.011,DFN_";"_ECLNSEQ_";"_EDTSEQ,5,VAL)
End DoDot:2
End DoDot:1
+42 ;
+43 QUIT
+44 ;
ADD(VPSARR,DFN) ; Addresses
+1 NEW VAPA
DO ADD^VADPT
+2 NEW VAL,TODAY
SET TODAY=$$DT^XLFDT()
+3 ;
+4 SET VAL=$PIECE($GET(VAPA(9)),U)
+5 IF VAL=""!(TODAY<VAL)
DO SETPERM(.VPSARR,DFN,.VAPA)
QUIT
+6 ;
+7 SET VAL=$PIECE($GET(VAPA(10)),U)
+8 IF VAL=""!(TODAY'>VAL)
DO SETMP(.VPSARR,DFN,.VAPA)
QUIT
+9 ;
+10 DO SETPERM(.VPSARR,DFN,.VAPA)
+11 QUIT
+12 ;
SETPERM(VPSARR,DFN,VAPA) ; PERM ADDRESS
+1 NEW VAL
+2 SET VAL=$GET(VAPA(1))
DO SET(.VPSARR,2,DFN,".111",VAL)
+3 SET VAL=$GET(VAPA(2))
DO SET(.VPSARR,2,DFN,".112",VAL)
+4 SET VAL=$GET(VAPA(3))
DO SET(.VPSARR,2,DFN,".113",VAL)
+5 SET VAL=$GET(VAPA(4))
DO SET(.VPSARR,2,DFN,".114",VAL)
+6 SET VAL=$PIECE($GET(VAPA(5)),U,2)
DO SET(.VPSARR,2,DFN,".115",VAL)
+7 SET VAL=$PIECE($GET(VAPA(7)),U,2)
DO SET(.VPSARR,2,DFN,".117",VAL)
+8 SET VAL=$GET(VAPA(8))
DO SET(.VPSARR,2,DFN,".131",VAL)
+9 SET VAL=$PIECE($GET(VAPA(11)),U,2)
DO SET(.VPSARR,2,DFN,".1112",VAL)
+10 SET VAL=$PIECE($GET(VAPA(25)),U,2)
DO SET(.VPSARR,2,DFN,".1173",VAL)
+11 SET VAL=$$GET1^DIQ(2,DFN_",",.1171,"E")
DO SET(.VPSARR,2,DFN,".1171",VAL)
+12 SET VAL=$$GET1^DIQ(2,DFN_",",.1172,"E")
DO SET(.VPSARR,2,DFN,".1172",VAL)
+13 SET VAL=$$GET1^DIQ(2,DFN_",",.121,"E")
DO SET(.VPSARR,2,DFN,".121",VAL)
+14 SET VAL=$$GET1^DIQ(2,DFN_",",.132,"E")
DO SET(.VPSARR,2,DFN,".132",VAL)
+15 SET VAL=$$GET1^DIQ(2,DFN_",",.134,"E")
DO SET(.VPSARR,2,DFN,".134",VAL)
+16 SET VAL=$$GET1^DIQ(2,DFN_",",.133,"E")
DO SET(.VPSARR,2,DFN,".133",VAL)
+17 DO SETCONF(.VPSARR,DFN,.VAPA)
+18 QUIT
+19 ;
SETMP(VPSARR,DFN,VAPA) ; SET TEMP ADD
+1 NEW VAL
+2 SET VAL=$GET(VAPA(1))
DO SET(.VPSARR,2,DFN,".1211",VAL)
+3 SET VAL=$GET(VAPA(2))
DO SET(.VPSARR,2,DFN,".1212",VAL)
+4 SET VAL=$GET(VAPA(3))
DO SET(.VPSARR,2,DFN,".1213",VAL)
+5 SET VAL=$GET(VAPA(4))
DO SET(.VPSARR,2,DFN,".1214",VAL)
+6 SET VAL=$PIECE($GET(VAPA(5)),U,2)
DO SET(.VPSARR,2,DFN,".1215",VAL)
+7 SET VAL=$PIECE($GET(VAPA(7)),U,2)
DO SET(.VPSARR,2,DFN,".12111",VAL)
+8 SET VAL=$GET(VAPA(8))
DO SET(.VPSARR,2,DFN,".1219",VAL)
+9 SET VAL=$PIECE($GET(VAPA(9)),U,2)
DO SET(.VPSARR,2,DFN,".1217",VAL)
+10 SET VAL=$PIECE($GET(VAPA(10)),U,2)
DO SET(.VPSARR,2,DFN,".1218",VAL)
+11 SET VAL=$PIECE($GET(VAPA(11)),U,2)
DO SET(.VPSARR,2,DFN,".12112",VAL)
+12 SET VAL=$PIECE($GET(VAPA(25)),U,2)
DO SET(.VPSARR,2,DFN,".1223",VAL)
+13 SET VAL=$$GET1^DIQ(2,DFN_",",.1221,"E")
DO SET(.VPSARR,2,DFN,".1221",VAL)
+14 SET VAL=$$GET1^DIQ(2,DFN_",",.1222,"E")
DO SET(.VPSARR,2,DFN,".1222",VAL)
+15 ;
+16 KILL VAPA
SET VAPA("P")=""
DO ADD^VADPT
+17 DO SETPERM(.VPSARR,DFN,.VAPA)
+18 ;
+19 QUIT
+20 ;
SETCONF(VPSARR,DFN,VAPA) ;Confindential address
+1 NEW VAL
+2 ; CONFIDENTIAL STREET [LINE 1]
SET VAL=$GET(VAPA(13))
DO SET(.VPSARR,2,DFN,".1411",VAL)
+3 ; CONFIDENTIAL STREET [LINE 2]
SET VAL=$GET(VAPA(14))
DO SET(.VPSARR,2,DFN,".1412",VAL)
+4 ; CONFIDENTIAL STREET [LINE 2]
SET VAL=$GET(VAPA(15))
DO SET(.VPSARR,2,DFN,".1413",VAL)
+5 ; CONFIDENTIAL ADDRESS CITY
SET VAL=$GET(VAPA(16))
DO SET(.VPSARR,2,DFN,".1414",VAL)
+6 ; CONFIDENTIAL ADDRESS STATE
SET VAL=$GET(VAPA(17))
SET VAL=$PIECE(VAL,U,2)
DO SET(.VPSARR,2,DFN,".1415",VAL)
+7 ; CONFIDENTIAL ADDRESS ZIP CODE
SET VAL=$GET(VAPA(18))
SET VAL=$PIECE(VAL,U,2)
DO SET(.VPSARR,2,DFN,".1416",VAL)
+8 ; CONFIDENTIAL ADDRESS COUNTY
SET VAL=$GET(VAPA(19))
DO SET(.VPSARR,2,DFN,".14111",VAL)
+9 ; CONFIDENTIAL START DATE
SET VAL=$GET(VAPA(20))
IF +VAL
DO SET(.VPSARR,2,DFN,".1417",+VAL)
+10 ; CONFIDENTIAL END DATE
SET VAL=$GET(VAPA(21))
IF +VAL
DO SET(.VPSARR,2,DFN,".1418",+VAL)
+11 ; CONFIDENTIAL ADDRESS ACTIVE?
SET VAL=$$GET1^DIQ(2,DFN_",",.14105,"E")
DO SET(.VPSARR,2,DFN,".14105",VAL)
+12 ; CONFIDENTIAL ADDRESS COUNTRY
SET VAL=$PIECE($GET(VAPA(28)),U,2)
DO SET(.VPSARR,2,DFN,".14116",VAL)
+13 ; CONFIDENTIAL PHONE NUMBER
SET VAL=$GET(VAPA(29))
DO SET(.VPSARR,2,DFN,".1315",VAL)
+14 ;
+15 ; -- Confidential Address categories
+16 NEW TYP
SET TYP=0
+17 FOR
SET TYP=$ORDER(VAPA(22,TYP))
if 'TYP
QUIT
Begin DoDot:1
+18 SET VAL=$PIECE(VAPA(22,TYP),U,2)
+19 ; CONFIDENTIAL ADDRESS CATEGORY
DO SET(.VPSARR,2.141,DFN_";"_TYP,".01",VAL)
End DoDot:1
+20 ;
+21 QUIT
+22 ;
OAD(VPSARR,DFN) ; Other Patient Variables
+1 ; NOK
NEW VAL,VAOA
SET VAOA("A")=7
DO OAD^VADPT
+2 SET VAL=$GET(VAOA(1))
DO SET(.VPSARR,2,DFN,".213",VAL)
+3 SET VAL=$GET(VAOA(2))
DO SET(.VPSARR,2,DFN,".214",VAL)
+4 SET VAL=$GET(VAOA(3))
DO SET(.VPSARR,2,DFN,".215",VAL)
+5 SET VAL=$GET(VAOA(4))
DO SET(.VPSARR,2,DFN,".216",VAL)
+6 SET VAL=$PIECE(VAOA(5),U,2)
DO SET(.VPSARR,2,DFN,".217",VAL)
+7 SET VAL=$GET(VAOA(11))
SET VAL=$PIECE(VAL,U,2)
DO SET(.VPSARR,2,DFN,".2207",VAL)
+8 SET VAL=$GET(VAOA(8))
DO SET(.VPSARR,2,DFN,".219",VAL)
+9 SET VAL=$GET(VAOA(9))
DO SET(.VPSARR,2,DFN,".211",VAL)
+10 SET VAL=$GET(VAOA(10))
DO SET(.VPSARR,2,DFN,".212",VAL)
+11 SET VAL=$$GET1^DIQ(2,DFN_",",.21011,"E")
DO SET(.VPSARR,2,DFN,".21011",VAL)
+12 ;
+13 ; Second NOK
KILL VAOA
SET VAOA("A")=3
DO OAD^VADPT
+14 SET VAL=$GET(VAOA(1))
DO SET(.VPSARR,2,DFN,".2193",VAL)
+15 SET VAL=$GET(VAOA(2))
DO SET(.VPSARR,2,DFN,".2194",VAL)
+16 SET VAL=$GET(VAOA(3))
DO SET(.VPSARR,2,DFN,".2195",VAL)
+17 SET VAL=$GET(VAOA(4))
DO SET(.VPSARR,2,DFN,".2196",VAL)
+18 SET VAL=$PIECE($GET(VAOA(5)),U,2)
DO SET(.VPSARR,2,DFN,".2197",VAL)
+19 SET VAL=$GET(VAOA(11))
SET VAL=$PIECE(VAL,U,2)
DO SET(.VPSARR,2,DFN,".2203",VAL)
+20 SET VAL=$GET(VAOA(8))
DO SET(.VPSARR,2,DFN,".2199",VAL)
+21 SET VAL=$GET(VAOA(9))
DO SET(.VPSARR,2,DFN,".2191",VAL)
+22 SET VAL=$GET(VAOA(10))
DO SET(.VPSARR,2,DFN,".2192",VAL)
+23 SET VAL=$$GET1^DIQ(2,DFN_",",.211011,"E")
DO SET(.VPSARR,2,DFN,".211011",VAL)
+24 ;
+25 ; Emergency Contact
KILL VAOA
SET VAOA("A")=1
DO OAD^VADPT
+26 SET VAL=$GET(VAOA(1))
DO SET(.VPSARR,2,DFN,".333",VAL)
+27 SET VAL=$GET(VAOA(2))
DO SET(.VPSARR,2,DFN,".334",VAL)
+28 SET VAL=$GET(VAOA(3))
DO SET(.VPSARR,2,DFN,".335",VAL)
+29 SET VAL=$GET(VAOA(4))
DO SET(.VPSARR,2,DFN,".336",VAL)
+30 SET VAL=$PIECE($GET(VAOA(5)),U,2)
DO SET(.VPSARR,2,DFN,".337",VAL)
+31 SET VAL=$PIECE($GET(VAOA(11)),U,2)
DO SET(.VPSARR,2,DFN,".2201",VAL)
+32 SET VAL=$GET(VAOA(8))
DO SET(.VPSARR,2,DFN,".339",VAL)
+33 SET VAL=$GET(VAOA(9))
DO SET(.VPSARR,2,DFN,".331",VAL)
+34 SET VAL=$GET(VAOA(10))
DO SET(.VPSARR,2,DFN,".332",VAL)
+35 SET VAL=$$GET1^DIQ(2,DFN_",",.33011,"E")
DO SET(.VPSARR,2,DFN,".33011",VAL)
+36 ;
+37 ; Second Emergency Contact
KILL VAOA
SET VAOA("A")=4
DO OAD^VADPT
+38 SET VAL=$GET(VAOA(1))
DO SET(.VPSARR,2,DFN,".3313",VAL)
+39 SET VAL=$GET(VAOA(2))
DO SET(.VPSARR,2,DFN,".3314",VAL)
+40 SET VAL=$GET(VAOA(3))
DO SET(.VPSARR,2,DFN,".3315",VAL)
+41 SET VAL=$GET(VAOA(4))
DO SET(.VPSARR,2,DFN,".3316",VAL)
+42 SET VAL=$PIECE($GET(VAOA(5)),U,2)
DO SET(.VPSARR,2,DFN,".3317",VAL)
+43 SET VAL=$PIECE($GET(VAOA(11)),U,2)
DO SET(.VPSARR,2,DFN,".2204",VAL)
+44 SET VAL=$GET(VAOA(8))
DO SET(.VPSARR,2,DFN,".3319",VAL)
+45 SET VAL=$GET(VAOA(9))
DO SET(.VPSARR,2,DFN,".3311",VAL)
+46 SET VAL=$GET(VAOA(10))
DO SET(.VPSARR,2,DFN,".3312",VAL)
+47 SET VAL=$$GET1^DIQ(2,DFN_",",.331011,"E")
DO SET(.VPSARR,2,DFN,".331011",VAL)
+48 ;
+49 ; Patient Employer
KILL VAOA
SET VAOA("A")=5
DO OAD^VADPT
+50 SET VAL=$GET(VAOA(8))
DO SET(.VPSARR,2,DFN,".3119",VAL)
+51 SET VAL=$GET(VAOA(9))
DO SET(.VPSARR,2,DFN,".3111",VAL)
+52 ;
+53 NEW VAPD
DO OPD^VADPT
+54 SET VAL=$PIECE($GET(VAPD(7)),U,2)
DO SET(.VPSARR,2,DFN,".31115",VAL)
+55 SET VAL=$$GET1^DIQ(2,DFN_",",.31116,"E")
DO SET(.VPSARR,2,DFN,".31116",VAL)
+56 ;
+57 ; Spouse's Employer
KILL VAOA
SET VAOA("A")=6
DO OAD^VADPT
+58 SET VAL=$GET(VAOA(8))
DO SET(.VPSARR,2,DFN,".258",VAL)
+59 SET VAL=$GET(VAOA(9))
DO SET(.VPSARR,2,DFN,".251",VAL)
+60 SET VAL=$$GET1^DIQ(2,DFN_",",.2515,"E")
DO SET(.VPSARR,2,DFN,".2515",VAL)
+61 SET VAL=$$GET1^DIQ(2,DFN_",",.2516,"E")
DO SET(.VPSARR,2,DFN,".2516",VAL)
+62 ;
+63 QUIT
+64 ;
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
