- 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 Jan 18, 2025@02:50:45 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 ;