Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRHS02

PXRHS02.m

Go to the documentation of this file.
  1. PXRHS02 ;ISL/SBW - PCE Visit data extract subroutines ;8-Nov-96
  1. ;;1.0;PCE PATIENT CARE ENCOUNTER;**13,73,121**;Aug 12, 1996
  1. GETREC(PXA,PXCAT,EXTRCODE,IEXDT,PXCNT) ; Get rec and load ^TMP("PXHSV",$J,
  1. N DIC,DIQ,DR,DA,REC,VISIT,TYPE,LOC,SERCAT,CHKOUT,CLINIC,WALKAPT,EMCODE,ELIG
  1. N HLOC,HLOCABB,OLOC
  1. S DIC=9000010,DA=PXA,DIQ="REC(",DIQ(0)="IE"
  1. ;--fix for fields .16 and .17 that were removed from file
  1. ; and .18 should alway be blank
  1. S DR=".01;.03;.06;.07;.08;.09;.11;.21;.22;2101"
  1. D EN^DIQ1
  1. Q:'$D(REC)
  1. Q:$G(PXCAT)'[REC(9000010,DA,.07,"I")!(REC(9000010,DA,.09,"I")'>0)!+(REC(9000010,DA,.11,"I"))
  1. S VISIT=REC(9000010,DA,.01,"I")
  1. S:+$G(IEXDT)'>0 IEXDT=9999999-VISIT
  1. S TYPE=REC(9000010,DA,.03,"E")
  1. S LOC=REC(9000010,DA,.06,"E")
  1. S SERCAT=REC(9000010,DA,.07,"E")
  1. S CLINIC=REC(9000010,DA,.08,"E")
  1. ;--fields .16 and .17 are not in file
  1. S WALKAPT="" ;REC(9000010,DA,.16,"E")
  1. S EMCODE="" ;REC(9000010,DA,.17,"E")
  1. ;--field .18 does not have data more that very short term
  1. S CHKOUT="" ;REC(9000010,DA,.18,"I")
  1. S ELIG=REC(9000010,DA,.21,"E")
  1. S HLOC=REC(9000010,DA,.22,"E")
  1. S HLOCABB=$$GETHLOC^PXRHS02(REC(9000010,DA,.22,"I"))
  1. S OLOC=REC(9000010,DA,2101,"E")
  1. S PXCNT=PXCNT+1
  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
  1. D:$G(EXTRCODE)["C" GETCPT^PXRHS02(PXA,IEXDT,PXCNT)
  1. D:$G(EXTRCODE)["D" GETPOV^PXRHS02(PXA,IEXDT,PXCNT)
  1. D:$G(EXTRCODE)["P" GETPROV^PXRHS02(PXA,IEXDT,PXCNT)
  1. Q
  1. GETHLOC(PXHLOC) ; Get hospital location abbreviation
  1. Q $P($G(^SC(+PXHLOC,0)),U,2)
  1. GETCPT(PXVDF,IDT,CNT) ; Get Procedures performed during the visit
  1. Q:$O(^AUPNVCPT("AD",PXVDF,""))=""
  1. N PXPDN,COMMENT
  1. S PXPDN=""
  1. F S PXPDN=$O(^AUPNVCPT("AD",PXVDF,PXPDN)) Q:'PXPDN D
  1. . N DIC,DIQ,DR,DA,REC,CPT,NARR,QTY,PRIM,SUBIEN,MOD
  1. . S DIC=9000010.18,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
  1. . S DR=".01;.04;.07;.16;81101"
  1. . D EN^DIQ1
  1. . Q:'$D(REC)
  1. . S CPT=REC(9000010.18,DA,.01,"I")
  1. . S NARR=REC(9000010.18,DA,.04,"E")
  1. . S QTY=REC(9000010.18,DA,.16,"E")
  1. . S PRIM=REC(9000010.18,DA,.07,"I")
  1. . S COMMENT=REC(9000010.18,DA,81101,"E")
  1. . S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN)=CPT_U_NARR_U_QTY_U_PRIM
  1. . S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN,"COM")=COMMENT
  1. . ;get modifiers
  1. . K REC D CPTMODIF^PXAAVCPT(PXPDN,.REC)
  1. . ;set modifiers
  1. . Q:'$D(REC)
  1. . S SUBIEN=""
  1. . F S SUBIEN=$O(REC(1,SUBIEN)) Q:SUBIEN="" D
  1. .. S MOD=$G(REC(1,SUBIEN,.01))
  1. .. I MOD'="" S MOD=$$MOD^ICPTMOD(MOD,"I",IDT)
  1. .. I $P(MOD,"^")<0 Q
  1. .. S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN,$P(MOD,"^",2))=""
  1. Q
  1. GETPOV(PXVDF,IDT,CNT) ; Get Purpose of visit
  1. Q:$O(^AUPNVPOV("AD",PXVDF,""))=""
  1. N PXPDN,COMMENT
  1. S PXPDN=""
  1. F S PXPDN=$O(^AUPNVPOV("AD",PXVDF,PXPDN)) Q:'PXPDN D
  1. . N DIC,DIQ,DR,DA,REC,POV,NARR,MOD,CAUSE,PLACE,PRIM
  1. . S DIC=9000010.07,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
  1. . S DR=".01;.04;.06;.12;81101"
  1. . D EN^DIQ1
  1. . Q:'$D(REC)
  1. . S POV=REC(9000010.07,DA,.01,"I")
  1. . S NARR=REC(9000010.07,DA,.04,"E")
  1. . S MOD=REC(9000010.07,DA,.06,"E")
  1. . S CAUSE="" ;REC(9000010.07,DA,.07,"E")
  1. . S PLACE="" ;REC(9000010.07,DA,.11,"E")
  1. . S PRIM=REC(9000010.07,DA,.12,"E")
  1. . S COMMENT=REC(9000010.07,DA,81101,"E")
  1. . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN)=POV_U_MOD_U_CAUSE_U_PLACE_U_PRIM
  1. . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN,"N")=NARR
  1. . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN,"COM")=COMMENT
  1. Q
  1. GETPROV(PXVDF,IDT,CNT) ;Entry point to get providers for a visits
  1. I $O(^AUPNVPRV("AD",PXVDF,""))="" Q
  1. S PXPDN=""
  1. F S PXPDN=$O(^AUPNVPRV("AD",PXVDF,PXPDN)) Q:'PXPDN D
  1. . N DIC,DIQ,DR,DA,REC,PROV,PRIM,IPRIM
  1. . S DIC=9000010.06,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
  1. . S DR=".01;.04"
  1. . D EN^DIQ1
  1. . Q:'$D(REC)
  1. . S PROV=REC(9000010.06,DA,.01,"E")
  1. . S PRIM=REC(9000010.06,DA,.04,"E")
  1. . S IPRIM=REC(9000010.06,DA,.04,"I")
  1. . S:IPRIM="" IPRIM="Z"
  1. . S ^TMP("PXHSV",$J,IDT,CNT,"P",IPRIM,PXPDN)=PROV_U_PRIM
  1. Q