source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFN15.m@ 1071

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

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1IBDFN15 ;ALB/CMR - ENCOUNTER FORM - OUTPUTS;JAN 4, 1996
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
3 ;
4 ; -- clinical reminders interface
5 ;
6SELRM ; -- Select reminders using old structures
7 N DIC
8 K @IBARY
9 W !
10 S QUIT=0
11 S DIC("S")="I '$P(^(0),U,6)"
12 S DIC=811.9,DIC(0)="AEMQZ"
13 D ^DIC K DIC
14 I +Y>0 S @IBARY=+Y_"^"_$P(Y(0),"^",3)_"^DUE NOW^LAST ACTIVITY^DUE DATE^COMBO"
15 Q
16 ;
17DISP ; -- display reminders on encounter form, treat like a dynamic
18 ; selection list
19 ;
20 N I,L,X,Y,Z,ORD,SEL,LAST,IBDCLRM,IBDX,CNT,TEXT,IBCLRMNM,CLRMTYP,COMBO,INVISIBL,NODE,GRPORD,GRP,CLRMCNT
21 I $G(IBLIST("EDITING CLRM")) G SELRM
22 ;
23 I +$G(IBLIST("CLRMLIST"))<1 S IBLIST("CLRMLIST")=2
24 S CLRMTYP=+$G(IBLIST("CLRMLIST"))-1
25 K ^TMP("PXRHM",$J),^TMP("PXRM",$J)
26 K ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT")
27 Q:'$G(DFN)!('$G(IBLIST))
28 ;
29 ; -- determine which reminders are due now
30 ; loop through groups and then selections
31 S GRPORD=""
32 F S GRPORD=$O(^IBE(357.4,"APO",+IBLIST,GRPORD)) Q:GRPORD="" S GRP=0 F S GRP=$O(^IBE(357.4,"APO",+IBLIST,GRPORD,GRP)) Q:'GRP D
33 .S NODE=$G(^IBE(357.4,+GRP,0))
34 .I $P(NODE,"^")="BLANK"!($P(NODE,"^",4)) S INVISIBL=1
35 .I '$G(INVISIBL) S CNT=$G(CNT)+1,^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^ "_$P(NODE,"^")
36 .D ONEGRP
37 ;
38 K RTNLIST(RTN("RTN")),^TMP("PXRM",$J),^TMP("PXHRM",$J)
39 I $G(CLRMCNT)<1 S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",1)="0^No Reminders in List"
40 I $G(CLRMCNT),'$D(^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT")) D
41 .S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",1)="0^No. Reminders Evaluated: "_CLRMCNT
42 .I CLRMTYP S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",2)="0^None Applicable this patient"
43 .I 'CLRMTYP S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",2)="0^None Due Now"
44 Q
45 ;
46ONEGRP ; -- loop through entries of one group in order
47 S ORD="" F S ORD=$O(^IBE(357.3,"APO",+IBLIST,GRP,ORD)) Q:ORD="" S SEL=0 F S SEL=$O(^IBE(357.3,"APO",+IBLIST,+GRP,ORD,SEL)) Q:'SEL D
48 .S IBDCLRM=$G(^IBE(357.3,SEL,0))
49 .I +IBDCLRM,'$P(IBDCLRM,"^",2) D
50 ..S CLRMCNT=$G(CLRMCNT)+1
51 ..D MAIN^PXRM(DFN,+IBDCLRM,CLRMTYP)
52 ..S TEXT=$O(^TMP("PXRHM",$J,+IBDCLRM,""))
53 ..Q:TEXT=""
54 ..S NODE=$G(^TMP("PXRHM",$J,+IBDCLRM,TEXT))
55 ..K ^TMP("PXRHM",$J),^TMP("PXRM",$J)
56 ..I $P(NODE,"^")="N/A" Q ;don't display not applicables
57 ..I CLRMTYP=0,$P(NODE,"^")'="DUE NOW" Q ;type of list DUE NOW only
58 ..S LAST=$P(NODE,"^",3) I +LAST,$L($P(LAST,"."))=7 S LAST=$$FMTE^XLFDT(LAST)
59 ..I $P(NODE,"^",5)="E" S LAST=LAST_" (E)" ;last activity was historical encounter, see px*1*38
60 ..S CNT=$G(CNT)+1
61 ..S COMBO=$S($P(NODE,"^")="DUE NOW":"DUE NOW",1:$$FMTE^XLFDT($P(NODE,"^",2)))
62 ..S ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^"_TEXT_"^"_$P(NODE,"^")_"^"_$$FMTE^XLFDT($P(NODE,"^",2))_"^"_LAST_"^"_COMBO
63 .;
64 .I $P(IBDCLRM,"^",2) S CNT=$G(CNT)+1,^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",CNT)="0^ "_$P(IBDCLRM,"^",6)
65 Q
66 ;
67TEST ;
68 N DFN,IBLIST,RTN,X
69 K ^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT")
70 S DFN=7169761 ;mnt,vbb-male
71 ;S DFN=7170189 ;mnt,vbb-female
72 ;S DFN=712 ;dev,den-male
73 S IBLIST("CLRMLIST")=2
74 S IBLIST=489 ;dev,den
75 S IBLIST=430 ;mnt,vbb
76 S RTN("RTN")="IBDFN15"
77 D DISP
78T1 S X="" F S X=$O(^TMP("IB",$J,"INTERFACES","PX CLINICAL REMINDERS PRINT",X)) Q:'X W !,^(X)
79 Q
Note: See TracBrowser for help on using the repository browser.