- 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 Mar 13, 2025@21:42:06 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
