source: FOIAVistA/tag/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXRHS02.m@ 628

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