PXRHS02 ;ISL/SBW - PCE Visit data extract subroutines ;8-Nov-96
;;1.0;PCE PATIENT CARE ENCOUNTER;**13,73,121**;Aug 12, 1996
GETREC(PXA,PXCAT,EXTRCODE,IEXDT,PXCNT) ; Get rec and load ^TMP("PXHSV",$J,
N DIC,DIQ,DR,DA,REC,VISIT,TYPE,LOC,SERCAT,CHKOUT,CLINIC,WALKAPT,EMCODE,ELIG
N HLOC,HLOCABB,OLOC
S DIC=9000010,DA=PXA,DIQ="REC(",DIQ(0)="IE"
;--fix for fields .16 and .17 that were removed from file
; and .18 should alway be blank
S DR=".01;.03;.06;.07;.08;.09;.11;.21;.22;2101"
D EN^DIQ1
Q:'$D(REC)
Q:$G(PXCAT)'[REC(9000010,DA,.07,"I")!(REC(9000010,DA,.09,"I")'>0)!+(REC(9000010,DA,.11,"I"))
S VISIT=REC(9000010,DA,.01,"I")
S:+$G(IEXDT)'>0 IEXDT=9999999-VISIT
S TYPE=REC(9000010,DA,.03,"E")
S LOC=REC(9000010,DA,.06,"E")
S SERCAT=REC(9000010,DA,.07,"E")
S CLINIC=REC(9000010,DA,.08,"E")
;--fields .16 and .17 are not in file
S WALKAPT="" ;REC(9000010,DA,.16,"E")
S EMCODE="" ;REC(9000010,DA,.17,"E")
;--field .18 does not have data more that very short term
S CHKOUT="" ;REC(9000010,DA,.18,"I")
S ELIG=REC(9000010,DA,.21,"E")
S HLOC=REC(9000010,DA,.22,"E")
S HLOCABB=$$GETHLOC^PXRHS02(REC(9000010,DA,.22,"I"))
S OLOC=REC(9000010,DA,2101,"E")
S PXCNT=PXCNT+1
S ^TMP("PXHSV",$J,IEXDT,PXCNT,0)=VISIT_U_TYPE_U_LOC_U_SERCAT_U_CHKOUT_U_HLOC_U_HLOCABB_U_OLOC_U_CLINIC_U_WALKAPT_U_EMCODE_U_ELIG
D:$G(EXTRCODE)["C" GETCPT^PXRHS02(PXA,IEXDT,PXCNT)
D:$G(EXTRCODE)["D" GETPOV^PXRHS02(PXA,IEXDT,PXCNT)
D:$G(EXTRCODE)["P" GETPROV^PXRHS02(PXA,IEXDT,PXCNT)
Q
GETHLOC(PXHLOC) ; Get hospital location abbreviation
Q $P($G(^SC(+PXHLOC,0)),U,2)
GETCPT(PXVDF,IDT,CNT) ; Get Procedures performed during the visit
Q:$O(^AUPNVCPT("AD",PXVDF,""))=""
N PXPDN,COMMENT
S PXPDN=""
F S PXPDN=$O(^AUPNVCPT("AD",PXVDF,PXPDN)) Q:'PXPDN D
. N DIC,DIQ,DR,DA,REC,CPT,NARR,QTY,PRIM,SUBIEN,MOD
. S DIC=9000010.18,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
. S DR=".01;.04;.07;.16;81101"
. D EN^DIQ1
. Q:'$D(REC)
. S CPT=REC(9000010.18,DA,.01,"I")
. S NARR=REC(9000010.18,DA,.04,"E")
. S QTY=REC(9000010.18,DA,.16,"E")
. S PRIM=REC(9000010.18,DA,.07,"I")
. S COMMENT=REC(9000010.18,DA,81101,"E")
. S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN)=CPT_U_NARR_U_QTY_U_PRIM
. S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN,"COM")=COMMENT
. ;get modifiers
. K REC D CPTMODIF^PXAAVCPT(PXPDN,.REC)
. ;set modifiers
. Q:'$D(REC)
. S SUBIEN=""
. F S SUBIEN=$O(REC(1,SUBIEN)) Q:SUBIEN="" D
.. S MOD=$G(REC(1,SUBIEN,.01))
.. I MOD'="" S MOD=$$MOD^ICPTMOD(MOD,"I",IDT)
.. I $P(MOD,"^")<0 Q
.. S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN,$P(MOD,"^",2))=""
Q
GETPOV(PXVDF,IDT,CNT) ; Get Purpose of visit
Q:$O(^AUPNVPOV("AD",PXVDF,""))=""
N PXPDN,COMMENT
S PXPDN=""
F S PXPDN=$O(^AUPNVPOV("AD",PXVDF,PXPDN)) Q:'PXPDN D
. N DIC,DIQ,DR,DA,REC,POV,NARR,MOD,CAUSE,PLACE,PRIM
. S DIC=9000010.07,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
. S DR=".01;.04;.06;.12;81101"
. D EN^DIQ1
. Q:'$D(REC)
. S POV=REC(9000010.07,DA,.01,"I")
. S NARR=REC(9000010.07,DA,.04,"E")
. S MOD=REC(9000010.07,DA,.06,"E")
. S CAUSE="" ;REC(9000010.07,DA,.07,"E")
. S PLACE="" ;REC(9000010.07,DA,.11,"E")
. S PRIM=REC(9000010.07,DA,.12,"E")
. S COMMENT=REC(9000010.07,DA,81101,"E")
. S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN)=POV_U_MOD_U_CAUSE_U_PLACE_U_PRIM
. S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN,"N")=NARR
. S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN,"COM")=COMMENT
Q
GETPROV(PXVDF,IDT,CNT) ;Entry point to get providers for a visits
I $O(^AUPNVPRV("AD",PXVDF,""))="" Q
S PXPDN=""
F S PXPDN=$O(^AUPNVPRV("AD",PXVDF,PXPDN)) Q:'PXPDN D
. N DIC,DIQ,DR,DA,REC,PROV,PRIM,IPRIM
. S DIC=9000010.06,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
. S DR=".01;.04"
. D EN^DIQ1
. Q:'$D(REC)
. S PROV=REC(9000010.06,DA,.01,"E")
. S PRIM=REC(9000010.06,DA,.04,"E")
. S IPRIM=REC(9000010.06,DA,.04,"I")
. S:IPRIM="" IPRIM="Z"
. S ^TMP("PXHSV",$J,IDT,CNT,"P",IPRIM,PXPDN)=PROV_U_PRIM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRHS02 3923 printed Oct 16, 2024@18:31 Page 2
PXRHS02 ;ISL/SBW - PCE Visit data extract subroutines ;8-Nov-96
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**13,73,121**;Aug 12, 1996
GETREC(PXA,PXCAT,EXTRCODE,IEXDT,PXCNT) ; Get rec and load ^TMP("PXHSV",$J,
+1 NEW DIC,DIQ,DR,DA,REC,VISIT,TYPE,LOC,SERCAT,CHKOUT,CLINIC,WALKAPT,EMCODE,ELIG
+2 NEW HLOC,HLOCABB,OLOC
+3 SET DIC=9000010
SET DA=PXA
SET DIQ="REC("
SET DIQ(0)="IE"
+4 ;--fix for fields .16 and .17 that were removed from file
+5 ; and .18 should alway be blank
+6 SET DR=".01;.03;.06;.07;.08;.09;.11;.21;.22;2101"
+7 DO EN^DIQ1
+8 if '$DATA(REC)
QUIT
+9 if $GET(PXCAT)'[REC(9000010,DA,.07,"I")!(REC(9000010,DA,.09,"I")'>0)!+(REC(9000010,DA,.11,"I"))
QUIT
+10 SET VISIT=REC(9000010,DA,.01,"I")
+11 if +$GET(IEXDT)'>0
SET IEXDT=9999999-VISIT
+12 SET TYPE=REC(9000010,DA,.03,"E")
+13 SET LOC=REC(9000010,DA,.06,"E")
+14 SET SERCAT=REC(9000010,DA,.07,"E")
+15 SET CLINIC=REC(9000010,DA,.08,"E")
+16 ;--fields .16 and .17 are not in file
+17 ;REC(9000010,DA,.16,"E")
SET WALKAPT=""
+18 ;REC(9000010,DA,.17,"E")
SET EMCODE=""
+19 ;--field .18 does not have data more that very short term
+20 ;REC(9000010,DA,.18,"I")
SET CHKOUT=""
+21 SET ELIG=REC(9000010,DA,.21,"E")
+22 SET HLOC=REC(9000010,DA,.22,"E")
+23 SET HLOCABB=$$GETHLOC^PXRHS02(REC(9000010,DA,.22,"I"))
+24 SET OLOC=REC(9000010,DA,2101,"E")
+25 SET PXCNT=PXCNT+1
+26 SET ^TMP("PXHSV",$JOB,IEXDT,PXCNT,0)=VISIT_U_TYPE_U_LOC_U_SERCAT_U_CHKOUT_U_HLOC_U_HLOCABB_U_OLOC_U_CLINIC_U_WALKAPT_U_EMCODE_U_ELIG
+27 if $GET(EXTRCODE)["C"
DO GETCPT^PXRHS02(PXA,IEXDT,PXCNT)
+28 if $GET(EXTRCODE)["D"
DO GETPOV^PXRHS02(PXA,IEXDT,PXCNT)
+29 if $GET(EXTRCODE)["P"
DO GETPROV^PXRHS02(PXA,IEXDT,PXCNT)
+30 QUIT
GETHLOC(PXHLOC) ; Get hospital location abbreviation
+1 QUIT $PIECE($GET(^SC(+PXHLOC,0)),U,2)
GETCPT(PXVDF,IDT,CNT) ; Get Procedures performed during the visit
+1 if $ORDER(^AUPNVCPT("AD",PXVDF,""))=""
QUIT
+2 NEW PXPDN,COMMENT
+3 SET PXPDN=""
+4 FOR
SET PXPDN=$ORDER(^AUPNVCPT("AD",PXVDF,PXPDN))
if 'PXPDN
QUIT
Begin DoDot:1
+5 NEW DIC,DIQ,DR,DA,REC,CPT,NARR,QTY,PRIM,SUBIEN,MOD
+6 SET DIC=9000010.18
SET DA=PXPDN
SET DIQ="REC("
SET DIQ(0)="IE"
+7 SET DR=".01;.04;.07;.16;81101"
+8 DO EN^DIQ1
+9 if '$DATA(REC)
QUIT
+10 SET CPT=REC(9000010.18,DA,.01,"I")
+11 SET NARR=REC(9000010.18,DA,.04,"E")
+12 SET QTY=REC(9000010.18,DA,.16,"E")
+13 SET PRIM=REC(9000010.18,DA,.07,"I")
+14 SET COMMENT=REC(9000010.18,DA,81101,"E")
+15 SET ^TMP("PXHSV",$JOB,IDT,CNT,"C",PXPDN)=CPT_U_NARR_U_QTY_U_PRIM
+16 SET ^TMP("PXHSV",$JOB,IDT,CNT,"C",PXPDN,"COM")=COMMENT
+17 ;get modifiers
+18 KILL REC
DO CPTMODIF^PXAAVCPT(PXPDN,.REC)
+19 ;set modifiers
+20 if '$DATA(REC)
QUIT
+21 SET SUBIEN=""
+22 FOR
SET SUBIEN=$ORDER(REC(1,SUBIEN))
if SUBIEN=""
QUIT
Begin DoDot:2
+23 SET MOD=$GET(REC(1,SUBIEN,.01))
+24 IF MOD'=""
SET MOD=$$MOD^ICPTMOD(MOD,"I",IDT)
+25 IF $PIECE(MOD,"^")<0
QUIT
+26 SET ^TMP("PXHSV",$JOB,IDT,CNT,"C",PXPDN,$PIECE(MOD,"^",2))=""
End DoDot:2
End DoDot:1
+27 QUIT
GETPOV(PXVDF,IDT,CNT) ; Get Purpose of visit
+1 if $ORDER(^AUPNVPOV("AD",PXVDF,""))=""
QUIT
+2 NEW PXPDN,COMMENT
+3 SET PXPDN=""
+4 FOR
SET PXPDN=$ORDER(^AUPNVPOV("AD",PXVDF,PXPDN))
if 'PXPDN
QUIT
Begin DoDot:1
+5 NEW DIC,DIQ,DR,DA,REC,POV,NARR,MOD,CAUSE,PLACE,PRIM
+6 SET DIC=9000010.07
SET DA=PXPDN
SET DIQ="REC("
SET DIQ(0)="IE"
+7 SET DR=".01;.04;.06;.12;81101"
+8 DO EN^DIQ1
+9 if '$DATA(REC)
QUIT
+10 SET POV=REC(9000010.07,DA,.01,"I")
+11 SET NARR=REC(9000010.07,DA,.04,"E")
+12 SET MOD=REC(9000010.07,DA,.06,"E")
+13 ;REC(9000010.07,DA,.07,"E")
SET CAUSE=""
+14 ;REC(9000010.07,DA,.11,"E")
SET PLACE=""
+15 SET PRIM=REC(9000010.07,DA,.12,"E")
+16 SET COMMENT=REC(9000010.07,DA,81101,"E")
+17 SET ^TMP("PXHSV",$JOB,IDT,CNT,"D",PXPDN)=POV_U_MOD_U_CAUSE_U_PLACE_U_PRIM
+18 SET ^TMP("PXHSV",$JOB,IDT,CNT,"D",PXPDN,"N")=NARR
+19 SET ^TMP("PXHSV",$JOB,IDT,CNT,"D",PXPDN,"COM")=COMMENT
End DoDot:1
+20 QUIT
GETPROV(PXVDF,IDT,CNT) ;Entry point to get providers for a visits
+1 IF $ORDER(^AUPNVPRV("AD",PXVDF,""))=""
QUIT
+2 SET PXPDN=""
+3 FOR
SET PXPDN=$ORDER(^AUPNVPRV("AD",PXVDF,PXPDN))
if 'PXPDN
QUIT
Begin DoDot:1
+4 NEW DIC,DIQ,DR,DA,REC,PROV,PRIM,IPRIM
+5 SET DIC=9000010.06
SET DA=PXPDN
SET DIQ="REC("
SET DIQ(0)="IE"
+6 SET DR=".01;.04"
+7 DO EN^DIQ1
+8 if '$DATA(REC)
QUIT
+9 SET PROV=REC(9000010.06,DA,.01,"E")
+10 SET PRIM=REC(9000010.06,DA,.04,"E")
+11 SET IPRIM=REC(9000010.06,DA,.04,"I")
+12 if IPRIM=""
SET IPRIM="Z"
+13 SET ^TMP("PXHSV",$JOB,IDT,CNT,"P",IPRIM,PXPDN)=PROV_U_PRIM
End DoDot:1
+14 QUIT
