source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXRHS02.m@ 1005

Last change on this file since 1005 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1PXRHS02 ;ISL/SBW - PCE Visit data extract subroutines ;8-Nov-96
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**13,73,121**;Aug 12, 1996
3GETREC(PXA,PXCAT,EXTRCODE,IEXDT,PXCNT) ; Get rec and load ^TMP("PXHSV",$J,
4 N DIC,DIQ,DR,DA,REC,VISIT,TYPE,LOC,SERCAT,CHKOUT,CLINIC,WALKAPT,EMCODE,ELIG
5 N HLOC,HLOCABB,OLOC
6 S DIC=9000010,DA=PXA,DIQ="REC(",DIQ(0)="IE"
7 ;--fix for fields .16 and .17 that were removed from file
8 ; and .18 should alway be blank
9 S DR=".01;.03;.06;.07;.08;.09;.11;.21;.22;2101"
10 D EN^DIQ1
11 Q:'$D(REC)
12 Q:$G(PXCAT)'[REC(9000010,DA,.07,"I")!(REC(9000010,DA,.09,"I")'>0)!+(REC(9000010,DA,.11,"I"))
13 S VISIT=REC(9000010,DA,.01,"I")
14 S:+$G(IEXDT)'>0 IEXDT=9999999-VISIT
15 S TYPE=REC(9000010,DA,.03,"E")
16 S LOC=REC(9000010,DA,.06,"E")
17 S SERCAT=REC(9000010,DA,.07,"E")
18 S CLINIC=REC(9000010,DA,.08,"E")
19 ;--fields .16 and .17 are not in file
20 S WALKAPT="" ;REC(9000010,DA,.16,"E")
21 S EMCODE="" ;REC(9000010,DA,.17,"E")
22 ;--field .18 does not have data more that very short term
23 S CHKOUT="" ;REC(9000010,DA,.18,"I")
24 S ELIG=REC(9000010,DA,.21,"E")
25 S HLOC=REC(9000010,DA,.22,"E")
26 S HLOCABB=$$GETHLOC^PXRHS02(REC(9000010,DA,.22,"I"))
27 S OLOC=REC(9000010,DA,2101,"E")
28 S PXCNT=PXCNT+1
29 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
30 D:$G(EXTRCODE)["C" GETCPT^PXRHS02(PXA,IEXDT,PXCNT)
31 D:$G(EXTRCODE)["D" GETPOV^PXRHS02(PXA,IEXDT,PXCNT)
32 D:$G(EXTRCODE)["P" GETPROV^PXRHS02(PXA,IEXDT,PXCNT)
33 Q
34GETHLOC(PXHLOC) ; Get hospital location abbreviation
35 Q $P($G(^SC(+PXHLOC,0)),U,2)
36GETCPT(PXVDF,IDT,CNT) ; Get Procedures performed during the visit
37 Q:$O(^AUPNVCPT("AD",PXVDF,""))=""
38 N PXPDN,COMMENT
39 S PXPDN=""
40 F S PXPDN=$O(^AUPNVCPT("AD",PXVDF,PXPDN)) Q:'PXPDN D
41 . N DIC,DIQ,DR,DA,REC,CPT,NARR,QTY,PRIM,SUBIEN,MOD
42 . S DIC=9000010.18,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
43 . S DR=".01;.04;.07;.16;81101"
44 . D EN^DIQ1
45 . Q:'$D(REC)
46 . S CPT=REC(9000010.18,DA,.01,"I")
47 . S NARR=REC(9000010.18,DA,.04,"E")
48 . S QTY=REC(9000010.18,DA,.16,"E")
49 . S PRIM=REC(9000010.18,DA,.07,"I")
50 . S COMMENT=REC(9000010.18,DA,81101,"E")
51 . S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN)=CPT_U_NARR_U_QTY_U_PRIM
52 . S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN,"COM")=COMMENT
53 . ;get modifiers
54 . K REC D CPTMODIF^PXAAVCPT(PXPDN,.REC)
55 . ;set modifiers
56 . Q:'$D(REC)
57 . S SUBIEN=""
58 . F S SUBIEN=$O(REC(1,SUBIEN)) Q:SUBIEN="" D
59 .. S MOD=$G(REC(1,SUBIEN,.01))
60 .. I MOD'="" S MOD=$$MOD^ICPTMOD(MOD,"I",IDT)
61 .. I $P(MOD,"^")<0 Q
62 .. S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN,$P(MOD,"^",2))=""
63 Q
64GETPOV(PXVDF,IDT,CNT) ; Get Purpose of visit
65 Q:$O(^AUPNVPOV("AD",PXVDF,""))=""
66 N PXPDN,COMMENT
67 S PXPDN=""
68 F S PXPDN=$O(^AUPNVPOV("AD",PXVDF,PXPDN)) Q:'PXPDN D
69 . N DIC,DIQ,DR,DA,REC,POV,NARR,MOD,CAUSE,PLACE,PRIM
70 . S DIC=9000010.07,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
71 . S DR=".01;.04;.06;.12;81101"
72 . D EN^DIQ1
73 . Q:'$D(REC)
74 . S POV=REC(9000010.07,DA,.01,"I")
75 . S NARR=REC(9000010.07,DA,.04,"E")
76 . S MOD=REC(9000010.07,DA,.06,"E")
77 . S CAUSE="" ;REC(9000010.07,DA,.07,"E")
78 . S PLACE="" ;REC(9000010.07,DA,.11,"E")
79 . S PRIM=REC(9000010.07,DA,.12,"E")
80 . S COMMENT=REC(9000010.07,DA,81101,"E")
81 . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN)=POV_U_MOD_U_CAUSE_U_PLACE_U_PRIM
82 . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN,"N")=NARR
83 . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN,"COM")=COMMENT
84 Q
85GETPROV(PXVDF,IDT,CNT) ;Entry point to get providers for a visits
86 I $O(^AUPNVPRV("AD",PXVDF,""))="" Q
87 S PXPDN=""
88 F S PXPDN=$O(^AUPNVPRV("AD",PXVDF,PXPDN)) Q:'PXPDN D
89 . N DIC,DIQ,DR,DA,REC,PROV,PRIM,IPRIM
90 . S DIC=9000010.06,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
91 . S DR=".01;.04"
92 . D EN^DIQ1
93 . Q:'$D(REC)
94 . S PROV=REC(9000010.06,DA,.01,"E")
95 . S PRIM=REC(9000010.06,DA,.04,"E")
96 . S IPRIM=REC(9000010.06,DA,.04,"I")
97 . S:IPRIM="" IPRIM="Z"
98 . S ^TMP("PXHSV",$J,IDT,CNT,"P",IPRIM,PXPDN)=PROV_U_PRIM
99 Q
Note: See TracBrowser for help on using the repository browser.