source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBGPOV.m@ 1552

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1PXBGPOV ;ISL/JVS,ESW - GATHER POV (DIAGNOSIS) ;8/10/04 1:30pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112,149,124**;Aug 12, 1996
3 ;
4POV(VISIT) ;--Gather the entries in the V POV file
5 ;
6 N IEN,QUANTITY,PROVIDER,SNARR,POV,GROUP,PXBC,POVI,I,PXCI
7 N DIC,DR,DA,DIQ,PRIM,PROBLEM,PXBPLA,PXBPL,PKG,SOURC
8 ;
9 K ^TMP("PXBU",$J),POV,PXBKY,PXBSAM,PXBSKY,PXDIGNS,NOPLLIST
10 K ^UTILITY("DIQ1",$J)
11 S FPRI="",PROBLEM=""
12 I $D(^AUPNVPOV("AD",VISIT)) D
13 .S IEN=0 F S IEN=$O(^AUPNVPOV("AD",VISIT,IEN)) Q:IEN'>0 D
14 ..S ^TMP("PXBU",$J,"POV",IEN)=""
15 ;
16A ;--Set array with DIAGNOSIS codes
17 ;
18 D PL^PXBGPL(PATIENT)
19 I $D(^TMP("PXBU",$J,"POV")) D
20 .S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"POV",IEN)) Q:IEN'>0 D
21 ..S DIC=9000010.07,DR=".01;1204;.04;.12;.17;81202;81203;80001:80007",DA=IEN,DIQ(0)="IE" D EN^DIQ1
22 ..S PROVIDER=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"1204","E"))
23 ..S LNARR=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".04","E"))
24 ..S POV=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".01","E"))
25 ..S PROBLEM="" S:$D(^TMP("PXBKYPL",$J,POV)) PROBLEM="YES"
26 ..S POVI=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".01","I"))
27 ..S PRIM=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".12","E"))
28 ..S ORDER=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".17","E"))
29 ..S PKG=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"81202","I"))
30 ..I PKG']"" S PKG="NONE"
31 ..S SOURC=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"81203","I"))
32 ..I SOURC']"" S SOURC="NONE"
33 ..S SNARR=$P($$ICDDX^ICDCODE(POVI,$G(IDATE)),U,4)
34 ..I $L(LNARR)'>30 S LNARR=$$DXNARR^PXUTL1(POVI,$G(IDATE))
35 ..S FPRI=FPRI_$E(PRIM,1,3) ;--Creating flag for Primary prompt
36 ..S GROUP=POV_"^"_PROVIDER_"^"_SNARR_"^"_PRIM_"^"_PROBLEM_"^"_LNARR_"^"_ORDER
37 ..; 1 2 3 4 5 6 7
38 ..I PRIM["PRI" S PXDIGNS("PRIMARY")=POV
39 ..S ^TMP("PXBPOV",$J,POV,IEN)=GROUP
40 ..S ^TMP("PXBGPOVMATCH",$J,POVI,IEN)=""
41 ..I $P(GROUP,"^",5)'["YES" S NOPLLIST=1
42 ..S GROUP=$G(^UTILITY("DIQ1",$J,9000010.07,IEN,80001,"I"))
43 ..F I=2:1:7 S GROUP=GROUP_U_$G(^UTILITY("DIQ1",$J,9000010.07,IEN,80000+I,"I"))
44 ..S PXCI(IEN)=GROUP,PXBREQ(POVI,"I")=GROUP
45 ;
46B ;--Add line numbers
47 ;
48 I $D(^TMP("PXBPOV",$J)) D
49 .S PXBC=0,POV="" F S POV=$O(^TMP("PXBPOV",$J,POV)) Q:POV="" Q:PXBC>40 D
50 ..S IEN=0 F S IEN=$O(^TMP("PXBPOV",$J,POV,IEN)) Q:IEN="" S PXBC=PXBC+1 D
51 ...S PXBKY(POV,PXBC)=$G(^TMP("PXBPOV",$J,POV,IEN)),PXBSAM(PXBC)=$G(^TMP("PXBPOV",$J,POV,IEN))
52 ...S PXBSKY(PXBC,IEN)=""
53 ...S PXBSAM(PXBC,"LNARR")=$P(PXBSAM(PXBC),U,6)
54 ...S PXBSAM(PXBC,"I")=PXCI(IEN)
55FINISG ;--finish up some variables
56 ;--FPRI=0 NO PRIMARY
57 S:FPRI'["PRI" FPRI=0 S:FPRI["PRI" FPRI=1
58EXIT ;--KILL
59 K ^TMP("PXBU",$J),^TMP("PXBKYPL",$J),^TMP("PXBSAMPL",$J),PXBSKYPL
60 K ^TMP("PXBPOV",$J),^UTILITY("DIQ1",$J)
61 S PXBCNT=+$G(PXBC)
62 Q
63 ;
64XLATE(VST,DX) ;Translate DX into POV from VST
65 Q:'$G(VST)!'$G(DX) "" Q:'$D(^AUPNVPOV("AD",VST)) ""
66 S DX=+$$ICDDX^ICDCODE(DX,+$G(^AUPNVSIT(VST,0))) Q:DX<0 ""
67 N IEN,ANS,VAL S (IEN,ANS,VAL)=""
68 F Q:ANS D
69 .S IEN=$O(^AUPNVPOV("AD",VST,IEN)) I 'IEN S ANS=1 Q
70 .S VAL=$G(^AUPNVPOV(IEN,0)),ANS=($P(VAL,U)=DX)
71 S ANS=IEN_U_DX_U_$P(VAL,U,12) S:IEN ANS=ANS_U_$G(^AUPNVPOV(IEN,800))
72 Q ANS
73 ;
Note: See TracBrowser for help on using the repository browser.