source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMGECK.m

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1PXRMGECK ;SLC/AGP,JVS-GEC Utilities Cont. ;7/14/05 10:42
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 Q
5TIUSTAT(DFN,GEC) ;Status of TIU Notes
6 N TIUDA,IEN,TITLE,NTTYP,STATUS,STATDA,STATUS,AUTDA,AUTHOR,DATE,DATEFM
7 Q:'$D(^PXRMD(801.5,"B",DFN)) 0
8 Q:'$D(^PXRMD(801.5,"AD",DFN,GEC)) 0
9 S IEN=$O(^PXRMD(801.5,"AD",DFN,GEC,0))
10 S TIUDA=$P($G(^PXRMD(801.5,IEN,0)),"^",4)
11 Q:TIUDA="" 0
12 Q:'$D(^TIU(8925,TIUDA,0)) 0
13 S NTTYP=$P($G(^TIU(8925,TIUDA,0)),"^",1)
14 S TITLE=$P($G(^TIU(8925.1,NTTYP,0)),"^",1)
15 S STATDA=$P($G(^TIU(8925,TIUDA,0)),"^",5)
16 S STATUS=$P($G(^TIU(8925.6,STATDA,0)),"^",1)
17 S AUTDA=$P($G(^TIU(8925,TIUDA,12)),"^",2) D
18 .I AUTDA="" S AUTHOR="unknown" Q
19 .S AUTHOR=$$GET1^DIQ(200,AUTDA,.01)
20 S DATEFM=$P($G(^TIU(8925,TIUDA,12)),"^",1) D
21 .I DATEFM="" S DATE="unknown" Q
22 .S DATE=$$FMTE^XLFDT(DATEFM,"D2")
23 Q 1_"^"_TITLE_":"_STATUS_":"_AUTHOR_":"_DATE
24 ;
25ACOPYDEL ;clean out ACOPY nodes
26 N NIEN,STATUS,STIEN,NOTEDFN,CDFN,EDT,GEC,DATE
27 Q:'$D(^PXRMD(801.5,"ACOPY"))
28 S NIEN=0 F S NIEN=$O(^PXRMD(801.5,"ACOPY",NIEN)) Q:NIEN="" D
29 .Q:'$D(^TIU(8925,NIEN))
30 .S STIEN=$P($G(^TIU(8925,NIEN,0)),"^",5)
31 .S STATUS=$P($G(^TIU(8925.6,STIEN,0)),"^",1)
32 .I STATUS="COMPLETED" K ^PXRMD(801.5,"ACOPY",NIEN)
33 .S NOTEDFN=$P($G(^TIU(8925,NIEN,0)),"^",2)
34 .S CDFN=0 F S CDFN=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN)) Q:CDFN="" D
35 ..I NOTEDFN'=CDFN K ^PXRMD(801.5,"ACOPY",NIEN,CDFN)
36 S NIEN=0 F S NIEN=$O(^PXRMD(801.5,"ACOPY",NIEN)) Q:NIEN="" D
37 .S CDFN=0 F S CDFN=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN)) Q:CDFN="" D
38 ..S EDT=0 F S EDT=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT)) Q:EDT="" D
39 ...S GEC="" F S GEC=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC)) Q:GEC="" D
40 ....S DATE=$O(^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC,0))
41 ....I '$D(^TIU(8925,NIEN)),$$FMDIFF^XLFDT(DT,DATE,1)>1 D
42 .....K ^PXRMD(801.5,"ACOPY",NIEN,CDFN,EDT,GEC)
43 Q
44 ;
45 ;
46REMOVE ;DELETE HEALTH FACTORS
47 N NODE0,NODE12,NODE812,VISIT,PKG,VAL,PCEARY
48 Q:'$D(HFARY)
49 S PCEARY="^TMP(""PXRMGECZ"",$J)"
50 S HFDA=0 F S HFDA=$O(HFARY(HFDA)) Q:HFDA="" D
51 .N NODE0,NODE12,NODE812
52 .S NODE0=$G(^AUPNVHF(HFDA,0))
53 .S NODE12=$G(^AUPNVHF(HFDA,12))
54 .S NODE812=$G(^AUPNVHF(HFDA,812))
55 .S VISIT=$P(NODE0,"^",3)
56 .S PKG=$P(NODE812,"^",2)
57 .S ^TMP("PXRMGECZ",$J,"HEALTH FACTOR",HFDA,"HEALTH FACTOR")=$P(NODE0,"^",1)
58 .S ^TMP("PXRMGECZ",$J,"HEALTH FACTOR",HFDA,"ENC PROVIDER")=$P(NODE12,"^",4)
59 .S ^TMP("PXRMGECZ",$J,"HEALTH FACTOR",HFDA,"EVENT D/T")=$P(NODE12,"^",1)
60 .S ^TMP("PXRMGECZ",$J,"HEALTH FACTOR",HFDA,"DELETE")=1
61 S VAL=$$DATA2PCE^PXAPI(PCEARY,PKG,GECT,VISIT)
62 K ^TMP("PXRMGECZ",$J)
63 ;
64 Q
65UPDATE(DFN,VISIT) ;Remove entry from 801.5 if deleted by dialog/tiu
66 ;
67 N HFDA,COUNT,SOURCE,GEC1,GEC2,GEC3,GECF,ENCDT,WHICH
68 N HERE,NOT,DA,DIA
69 Q:DFN=""
70 ;
71 ;Delete Health Factors if not TIU document
72 ;
73 S ENCDT=$O(^PXRMD(801.5,"AC",DFN,""))
74 Q:ENCDT=""
75 ;
76 S (GEC1,GEC2,GEC3,GECF)=0
77 ;GET IEN FOR DATA SOURCES FOR GEC
78 I $D(^PX(839.7,"B","GEC1")) D
79 .S GEC1=$O(^PX(839.7,"B","GEC1","")),WHICH(GEC1)="GEC1",NOT("GEC1")=""
80 I $D(^PX(839.7,"B","GEC2")) D
81 .S GEC2=$O(^PX(839.7,"B","GEC2","")),WHICH(GEC2)="GEC2",NOT("GEC2")=""
82 I $D(^PX(839.7,"B","GEC3")) D
83 .S GEC3=$O(^PX(839.7,"B","GEC3","")),WHICH(GEC3)="GEC3",NOT("GEC3")=""
84 I $D(^PX(839.7,"B","GECF")) D
85 .S GECF=$O(^PX(839.7,"B","GECF","")),WHICH(GECF)="GECF",NOT("GECF")=""
86 ;
87 ;
88 S COUNT=0
89 S HFDA="" F S HFDA=$O(^AUPNVHF("C",DFN,HFDA)) Q:HFDA="" D
90 .I $D(^AUPNVHF(HFDA,12)) D
91 ..I $P($G(^AUPNVHF(HFDA,12)),"^",1)=ENCDT D
92 ...S SOURCE=$P($G(^AUPNVHF(HFDA,812)),"^",3)
93 ...Q:SOURCE=""
94 ...I (SOURCE=$G(GEC1))!(SOURCE=$G(GEC2))!(SOURCE=$G(GEC3))!(SOURCE=$G(GECF)) D
95 ....S HERE($G(WHICH(SOURCE)))=""
96 ....K NOT($G(WHICH(SOURCE)))
97 ....S COUNT=COUNT+1
98 S DIA="" F S DIA=$O(NOT(DIA)) Q:DIA="" D
99 .S DA=$O(^PXRMD(801.5,"AD",DFN,DIA,0))
100 .Q:DA=""
101 .S ^PXRMD(801.5,"ACOPY",DFN,ENCDT,DIA)=$P($G(^PXRMD(801.5,DA,0)),"^",4)
102 .S DIK="^PXRMD(801.5," D ^DIK
103 Q
104 ;
105 ;
Note: See TracBrowser for help on using the repository browser.