RCXVDC2 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
;;4.5;Accounts Receivable;**201,227,228**;Mar 20, 1995
;
; PATIENT FILE (# 2)
Q
D2 ;
NEW RCXVDT,RCXVD,RCXVD1,RCXVD2,RCXVD3,RCXVPF,RCXVDA,RCXVENR,RCXVPE
N RCXVPE1,RCXVCT,RCMTYP,RCMTDA,RCMTDT,PC1,PC2,PC3
NEW RCXVCTY,RCXVICN,RCXVELG,VADM
S RCXVD=$G(^DPT(DFN,0))
S RCXVDT=$P(RCXVD,U,3)
S RCXVDA=$E($$HLDATE^HLFNC(RCXVDT),1,8) ; DT of Birth
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD,U,9) ; SSN
S RCXVICN=$P($G(^DPT(DFN,"MPI")),U,1)
S RCXVDA=RCXVDA_RCXVU_RCXVICN ; ICN
S RCXVDA=RCXVDA_RCXVU_$P($$SITE^VASITE(),U,3)_"v"_DFN ; IEN
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD,U,2) ; SEX
S RCXVD1=$G(^DPT(DFN,.11))
S RCXVD2=$G(^DPT(DFN,.35))
S RCXVD3="^^^^^^^^^^^"
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,6) ; ZIPCODE
;
NEW VAPA,VAERR
D ADD^VADPT
S RCXVCTY=$P($G(VAPA(7)),U,2)
S RCXVDA=RCXVDA_RCXVU_RCXVCTY ; COUNTY
;
S RCXVPE="",RCXVPE1=""
S RCXVENR=$P($G(^DPT(DFN,"ENR")),U,1)
I RCXVENR'="" D
. S RCXVPE=$P($G(^DGEN(27.11,RCXVENR,0)),U,7) ; Enrollment priority
. S RCXVPE1=$$GET1^DIQ(27.11,RCXVENR_",",.12,"E") ; Enrollment subgroup
;
;Primary Eligibility Code
S RCXVELG=$P($G(^DPT(DFN,.36)),U,1)
I RCXVELG'="" S RCXVELG=$P($G(^DIC(8,RCXVELG,0)),U,1)
S RCXVDA=RCXVDA_RCXVU_RCXVPE_RCXVU_RCXVPE1_RCXVU_RCXVELG
S RCXVDT=$P(RCXVD2,U)
D DEM^VADPT S RCXVDT=$P(VADM(6),U)
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;Date of Death
S RCXVDA=RCXVDA_RCXVU_$P(VADM(10),U,2) ;Marital Status
;means test data
F RCMTYP=1,2,3,4 D:$D(^DGMT(408.31,"AID",RCMTYP,DFN))
. S PC3=RCMTYP*3,PC2=PC3-1,PC1=PC3-2
. S RCMTDT=$O(^DGMT(408.31,"AID",RCMTYP,DFN,-9999999))
. S RCMTDA=$O(^DGMT(408.31,"AID",RCMTYP,DFN,RCMTDT,0)) Q:'RCMTDA
. S RCXVDT=-RCMTDT
. S $P(RCXVD3,U,PC1)=$E($$HLDATE^HLFNC(RCXVDT),1,8) ;Test Date
. S $P(RCXVD3,U,PC2)=$$GET1^DIQ(408.31,RCMTDA_",",.03,"E") ;Test Status
. S $P(RCXVD3,U,PC3)=$P($G(^DGMT(408.31,RCMTDA,0)),U,4) ;Income
. Q
S ^TMP($J,RCXVBLN,"2-2A")=RCXVDA
S ^TMP($J,RCXVBLN,"2-2B")=RCXVD3
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXVDC2 2041 printed Apr 09, 2024@20:49:54 Page 2
RCXVDC2 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
+1 ;;4.5;Accounts Receivable;**201,227,228**;Mar 20, 1995
+2 ;
+3 ; PATIENT FILE (# 2)
+4 QUIT
D2 ;
+1 NEW RCXVDT,RCXVD,RCXVD1,RCXVD2,RCXVD3,RCXVPF,RCXVDA,RCXVENR,RCXVPE
+2 NEW RCXVPE1,RCXVCT,RCMTYP,RCMTDA,RCMTDT,PC1,PC2,PC3
+3 NEW RCXVCTY,RCXVICN,RCXVELG,VADM
+4 SET RCXVD=$GET(^DPT(DFN,0))
+5 SET RCXVDT=$PIECE(RCXVD,U,3)
+6 ; DT of Birth
SET RCXVDA=$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+7 ; SSN
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD,U,9)
+8 SET RCXVICN=$PIECE($GET(^DPT(DFN,"MPI")),U,1)
+9 ; ICN
SET RCXVDA=RCXVDA_RCXVU_RCXVICN
+10 ; IEN
SET RCXVDA=RCXVDA_RCXVU_$PIECE($$SITE^VASITE(),U,3)_"v"_DFN
+11 ; SEX
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD,U,2)
+12 SET RCXVD1=$GET(^DPT(DFN,.11))
+13 SET RCXVD2=$GET(^DPT(DFN,.35))
+14 SET RCXVD3="^^^^^^^^^^^"
+15 ; ZIPCODE
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD1,U,6)
+16 ;
+17 NEW VAPA,VAERR
+18 DO ADD^VADPT
+19 SET RCXVCTY=$PIECE($GET(VAPA(7)),U,2)
+20 ; COUNTY
SET RCXVDA=RCXVDA_RCXVU_RCXVCTY
+21 ;
+22 SET RCXVPE=""
SET RCXVPE1=""
+23 SET RCXVENR=$PIECE($GET(^DPT(DFN,"ENR")),U,1)
+24 IF RCXVENR'=""
Begin DoDot:1
+25 ; Enrollment priority
SET RCXVPE=$PIECE($GET(^DGEN(27.11,RCXVENR,0)),U,7)
+26 ; Enrollment subgroup
SET RCXVPE1=$$GET1^DIQ(27.11,RCXVENR_",",.12,"E")
End DoDot:1
+27 ;
+28 ;Primary Eligibility Code
+29 SET RCXVELG=$PIECE($GET(^DPT(DFN,.36)),U,1)
+30 IF RCXVELG'=""
SET RCXVELG=$PIECE($GET(^DIC(8,RCXVELG,0)),U,1)
+31 SET RCXVDA=RCXVDA_RCXVU_RCXVPE_RCXVU_RCXVPE1_RCXVU_RCXVELG
+32 SET RCXVDT=$PIECE(RCXVD2,U)
+33 DO DEM^VADPT
SET RCXVDT=$PIECE(VADM(6),U)
+34 ;Date of Death
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+35 ;Marital Status
SET RCXVDA=RCXVDA_RCXVU_$PIECE(VADM(10),U,2)
+36 ;means test data
+37 FOR RCMTYP=1,2,3,4
if $DATA(^DGMT(408.31,"AID",RCMTYP,DFN))
Begin DoDot:1
+38 SET PC3=RCMTYP*3
SET PC2=PC3-1
SET PC1=PC3-2
+39 SET RCMTDT=$ORDER(^DGMT(408.31,"AID",RCMTYP,DFN,-9999999))
+40 SET RCMTDA=$ORDER(^DGMT(408.31,"AID",RCMTYP,DFN,RCMTDT,0))
if 'RCMTDA
QUIT
+41 SET RCXVDT=-RCMTDT
+42 ;Test Date
SET $PIECE(RCXVD3,U,PC1)=$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+43 ;Test Status
SET $PIECE(RCXVD3,U,PC2)=$$GET1^DIQ(408.31,RCMTDA_",",.03,"E")
+44 ;Income
SET $PIECE(RCXVD3,U,PC3)=$PIECE($GET(^DGMT(408.31,RCMTDA,0)),U,4)
+45 QUIT
End DoDot:1
+46 SET ^TMP($JOB,RCXVBLN,"2-2A")=RCXVDA
+47 SET ^TMP($JOB,RCXVBLN,"2-2B")=RCXVD3
+48 QUIT
+49 ;
