RMPFRPC1 ;DALC/PJU - Module to get Demographics for Patient ;06/18/08
;;3.0;REMOTE ORDER ENTRY SYSTEM;**1,4**;Feb 9, 2011;Build 19
;;Per VHA Directive 10-92-142 this routine should not be modified
;;Uses supported IA's: 2701, 4440, 10061
;;Added to IA: 767
START(RE,DFN) ;Descrip of ret array(RE) in EXAMP at bottom of pg
;Called from RPC 'RMPFDEMOG' in Delphi routine uRMPFR3Patient.pas
;input: array name by ref, DFN
;output: 2 char term used in name-value pairs for URL
I '$G(DFN) D G END
.S ER="** Must have a DFN defined to continue. Exiting **"
K RE ;can set param to clear between calls
N ARR,BD,CL,CI,ED,EL,ER,ES,GP,ICN,L1,L2,L3
N NM,PD,PN,PR,SR,SS,ST,TE,TD,VH,VT,ZP
S (BD,CL,CI,ED,EL,ER,ES,GP,ICN,L1,L2,L3)=""
S (NM,PD,PN,PR,SR,SS,ST,TE,TD,VH,VT,ZP)=""
F X=0,11:1:31 S RE(X)=""
D DEM^VADPT ; demographic vars
I $G(VAERR) D G END
.S ER="**Problem in retrieving Demographic values. Exiting.**"
I $D(^DGSL(38.1,"B",DFN)) D ;IA#767
.S SR=$O(^DGSL(38.1,"B",DFN,0)) ;ck for sensitive record
.I SR,$P($G(^DGSL(38.1,SR,0)),U,2) S RE(26)=1
S NM=$G(VADM(1)),RE(11)=NM ;name
S SS=$P($G(VADM(2)),U,1),RE(12)=SS ;ssn
S BD=$G(VADM(3)),RE(13)=BD ;DOB
D ADD^VADPT ; current addr
I $G(VAERR) D G END
.S ER="**Problem in retrieving Address values. Exiting**"
S L1=$G(VAPA(1)),RE(14)=L1
S L2=$G(VAPA(2)),RE(15)=L2
S L3=$G(VAPA(3)),RE(16)=L3
S CI=$G(VAPA(4)),RE(17)=CI
S ST=$P($G(VAPA(5)),U,1) ;State file pointer
I 'ST D G END
.S ER="**STATE field of address in local PATIENT record is missing. Exiting."
E S X=ST,DIC="5",DIC(0)="NZ" D ^DIC K DIC D G:$L(ER) END
.I +Y<1 K Y D Q
..S ER="**STATE field of address in local PATIENT record is not valid. Exiting."
.S ST=$P(Y(0),U,2) K Y ;State abbrev
S RE(18)=$P($G(VAPA(5)),U,1)_U_ST
S ZP=$S($G(VAPA(11)):VAPA(11),1:VAPA(6)),RE(19)=$P(ZP,U,1)
S TD=$G(VAPA(9)),RE(20)=TD
S TE=$G(VAPA(10)),RE(21)=TE
S PN=$G(VAPA(8)),RE(22)=PN
END ;get eligibility information
;ARR is killed and re-set in RMPFRPC0
D START^RMPFRPC0(.ARR,DFN) ;elig vars
S RE(0)=$G(ARR(0)) ;FM DOD ^ external
S RE(23)=DT ;$P(ARR(8),U,7) ;El stat dt - as of today
S RE(24)=$G(ARR(2)) ;R3 calc elig code
I RE(24)="" S RE(24)=$G(ARR(8)) ;just elig R3*4
;elig^app(1)/dis(0)/sub(2)/exp(3)^PSuser^ASuser^ReqDt^SugEl^ActDt
S RE(25)=$P($G(ARR(3)),U,1) ;elig status
I $L($G(ER)) S RE(27)=ER ;error msg from VADPT calls
I $G(RE(27))="" S RE(27)=$G(ARR(5)) ;error msg from elig call
S RE(28)=$G(ARR(6)) ;prim elig
S RE(29)=$G(ARR(7)) ;priority group
S ICN="",X="MPIF001" X ^%ZOSF("TEST")
I $T S ICN=$$GETICN^MPIF001(DFN)
S:(ICN<1) ICN="" ;"***ICN NOT FOUND***"
S RE(30)=ICN
S VH=0 ;ck for production account
S X="XUPROD" X ^%ZOSF("TEST") I $T D
.S VH=$$PROD^XUPROD()
.I VH'=1 S VH=0
S RE(31)=VH
EXIT F X=11:1:31 S RE(X)=$$CLEAN(RE(X))
;ZW RE ;TESTING R3*4
K S0,S1,S2,S6,YY,POP,VAERR
D KVAR^VADPT
Q
;
CLEAN(RMVAR) ;Remove symbols that should not go through URL
N RMPFRTN
S RMPFRTN=$TR(RMVAR,"@#%?&/\*","")
ENDC Q RMPFRTN
;
EXAMP ;return sorted array to calling application
;RPCBroker lookup is done to retrieve the patient DFN.
;A call is then made to this routine through the RMPFDEMOG RPC.
;From the PATIENT file, we get the name, SSN, date of birth,
;current address, and temporary address parameters.
;will return to the Delphi app subscripts in same order
;created during calculation in the RE array (passed by ref)
;PD = RE(0)=date of death msg or ""
;NM = RE(11)=name
;SS = RE(12)=SSN
;BD = RE(13)=DOB
;L1 = RE(14)=current ad1
;L2 = RE(15)=current ad2
;L3 = RE(16)=current ad3
;CI = RE(17)=current city
;ST = RE(18)=current st
;ZP = RE(19)=current zip
;TD = RE(20)=t start date
;TE = RE(21)=t end date
;PN = RE(22)=current phone
;ED = RE(23)=eligibility status date FM
;EL = RE(24)=R3 elig cd ;;^1/2/3^PS-user^AS-user^reqDt^sugEl^actDt
;ES = RE(25)=eligibility status
;SR = RE(26)=sensitive record
;ER = RE(27)=error msg
;PR = RE(28)=primary elig
;GP = RE(29)=priority group
;ICN= RE(30)=Integration Control Number for MPI
;VH = RE(31)=1 if a production account
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFRPC1 4273 printed Sep 23, 2025@20:13:21 Page 2
RMPFRPC1 ;DALC/PJU - Module to get Demographics for Patient ;06/18/08
+1 ;;3.0;REMOTE ORDER ENTRY SYSTEM;**1,4**;Feb 9, 2011;Build 19
+2 ;;Per VHA Directive 10-92-142 this routine should not be modified
+3 ;;Uses supported IA's: 2701, 4440, 10061
+4 ;;Added to IA: 767
START(RE,DFN) ;Descrip of ret array(RE) in EXAMP at bottom of pg
+1 ;Called from RPC 'RMPFDEMOG' in Delphi routine uRMPFR3Patient.pas
+2 ;input: array name by ref, DFN
+3 ;output: 2 char term used in name-value pairs for URL
+4 IF '$GET(DFN)
Begin DoDot:1
+5 SET ER="** Must have a DFN defined to continue. Exiting **"
End DoDot:1
GOTO END
+6 ;can set param to clear between calls
KILL RE
+7 NEW ARR,BD,CL,CI,ED,EL,ER,ES,GP,ICN,L1,L2,L3
+8 NEW NM,PD,PN,PR,SR,SS,ST,TE,TD,VH,VT,ZP
+9 SET (BD,CL,CI,ED,EL,ER,ES,GP,ICN,L1,L2,L3)=""
+10 SET (NM,PD,PN,PR,SR,SS,ST,TE,TD,VH,VT,ZP)=""
+11 FOR X=0,11:1:31
SET RE(X)=""
+12 ; demographic vars
DO DEM^VADPT
+13 IF $GET(VAERR)
Begin DoDot:1
+14 SET ER="**Problem in retrieving Demographic values. Exiting.**"
End DoDot:1
GOTO END
+15 ;IA#767
IF $DATA(^DGSL(38.1,"B",DFN))
Begin DoDot:1
+16 ;ck for sensitive record
SET SR=$ORDER(^DGSL(38.1,"B",DFN,0))
+17 IF SR
IF $PIECE($GET(^DGSL(38.1,SR,0)),U,2)
SET RE(26)=1
End DoDot:1
+18 ;name
SET NM=$GET(VADM(1))
SET RE(11)=NM
+19 ;ssn
SET SS=$PIECE($GET(VADM(2)),U,1)
SET RE(12)=SS
+20 ;DOB
SET BD=$GET(VADM(3))
SET RE(13)=BD
+21 ; current addr
DO ADD^VADPT
+22 IF $GET(VAERR)
Begin DoDot:1
+23 SET ER="**Problem in retrieving Address values. Exiting**"
End DoDot:1
GOTO END
+24 SET L1=$GET(VAPA(1))
SET RE(14)=L1
+25 SET L2=$GET(VAPA(2))
SET RE(15)=L2
+26 SET L3=$GET(VAPA(3))
SET RE(16)=L3
+27 SET CI=$GET(VAPA(4))
SET RE(17)=CI
+28 ;State file pointer
SET ST=$PIECE($GET(VAPA(5)),U,1)
+29 IF 'ST
Begin DoDot:1
+30 SET ER="**STATE field of address in local PATIENT record is missing. Exiting."
End DoDot:1
GOTO END
+31 IF '$TEST
SET X=ST
SET DIC="5"
SET DIC(0)="NZ"
DO ^DIC
KILL DIC
Begin DoDot:1
+32 IF +Y<1
KILL Y
Begin DoDot:2
+33 SET ER="**STATE field of address in local PATIENT record is not valid. Exiting."
End DoDot:2
QUIT
+34 ;State abbrev
SET ST=$PIECE(Y(0),U,2)
KILL Y
End DoDot:1
if $LENGTH(ER)
GOTO END
+35 SET RE(18)=$PIECE($GET(VAPA(5)),U,1)_U_ST
+36 SET ZP=$SELECT($GET(VAPA(11)):VAPA(11),1:VAPA(6))
SET RE(19)=$PIECE(ZP,U,1)
+37 SET TD=$GET(VAPA(9))
SET RE(20)=TD
+38 SET TE=$GET(VAPA(10))
SET RE(21)=TE
+39 SET PN=$GET(VAPA(8))
SET RE(22)=PN
END ;get eligibility information
+1 ;ARR is killed and re-set in RMPFRPC0
+2 ;elig vars
DO START^RMPFRPC0(.ARR,DFN)
+3 ;FM DOD ^ external
SET RE(0)=$GET(ARR(0))
+4 ;$P(ARR(8),U,7) ;El stat dt - as of today
SET RE(23)=DT
+5 ;R3 calc elig code
SET RE(24)=$GET(ARR(2))
+6 ;just elig R3*4
IF RE(24)=""
SET RE(24)=$GET(ARR(8))
+7 ;elig^app(1)/dis(0)/sub(2)/exp(3)^PSuser^ASuser^ReqDt^SugEl^ActDt
+8 ;elig status
SET RE(25)=$PIECE($GET(ARR(3)),U,1)
+9 ;error msg from VADPT calls
IF $LENGTH($GET(ER))
SET RE(27)=ER
+10 ;error msg from elig call
IF $GET(RE(27))=""
SET RE(27)=$GET(ARR(5))
+11 ;prim elig
SET RE(28)=$GET(ARR(6))
+12 ;priority group
SET RE(29)=$GET(ARR(7))
+13 SET ICN=""
SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
+14 IF $TEST
SET ICN=$$GETICN^MPIF001(DFN)
+15 ;"***ICN NOT FOUND***"
if (ICN<1)
SET ICN=""
+16 SET RE(30)=ICN
+17 ;ck for production account
SET VH=0
+18 SET X="XUPROD"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+19 SET VH=$$PROD^XUPROD()
+20 IF VH'=1
SET VH=0
End DoDot:1
+21 SET RE(31)=VH
EXIT FOR X=11:1:31
SET RE(X)=$$CLEAN(RE(X))
+1 ;ZW RE ;TESTING R3*4
+2 KILL S0,S1,S2,S6,YY,POP,VAERR
+3 DO KVAR^VADPT
+4 QUIT
+5 ;
CLEAN(RMVAR) ;Remove symbols that should not go through URL
+1 NEW RMPFRTN
+2 SET RMPFRTN=$TRANSLATE(RMVAR,"@#%?&/\*","")
ENDC QUIT RMPFRTN
+1 ;
EXAMP ;return sorted array to calling application
+1 ;RPCBroker lookup is done to retrieve the patient DFN.
+2 ;A call is then made to this routine through the RMPFDEMOG RPC.
+3 ;From the PATIENT file, we get the name, SSN, date of birth,
+4 ;current address, and temporary address parameters.
+5 ;will return to the Delphi app subscripts in same order
+6 ;created during calculation in the RE array (passed by ref)
+7 ;PD = RE(0)=date of death msg or ""
+8 ;NM = RE(11)=name
+9 ;SS = RE(12)=SSN
+10 ;BD = RE(13)=DOB
+11 ;L1 = RE(14)=current ad1
+12 ;L2 = RE(15)=current ad2
+13 ;L3 = RE(16)=current ad3
+14 ;CI = RE(17)=current city
+15 ;ST = RE(18)=current st
+16 ;ZP = RE(19)=current zip
+17 ;TD = RE(20)=t start date
+18 ;TE = RE(21)=t end date
+19 ;PN = RE(22)=current phone
+20 ;ED = RE(23)=eligibility status date FM
+21 ;EL = RE(24)=R3 elig cd ;;^1/2/3^PS-user^AS-user^reqDt^sugEl^actDt
+22 ;ES = RE(25)=eligibility status
+23 ;SR = RE(26)=sensitive record
+24 ;ER = RE(27)=error msg
+25 ;PR = RE(28)=primary elig
+26 ;GP = RE(29)=priority group
+27 ;ICN= RE(30)=Integration Control Number for MPI
+28 ;VH = RE(31)=1 if a production account
