source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF18A1.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1IBDF18A1 ;ALB/CJM/AAS - ENCOUNTER FORM - utilities for PCE ;12-AUG-94
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, 1997
3 ;
4COPYLIST(LIST,ARY,COUNT) ;
5 ; -- copies the entries from LIST to @ARY, starting subscript at COUNT+1
6 ;
7 N SLCTN,NODE,NODE1,NODE2,TSUBCOL,GROUP,ORDER,HDR,PRNT
8 ;
9 D SUBCOL(LIST,.TSUBCOL) ;find the subcolumn containing the text
10 ;
11 S PRNT=""
12 F S PRNT=$O(^IBE(357.4,"APO",LIST,PRNT)) Q:PRNT="" D
13 . S GROUP=""
14 . F S GROUP=$O(^IBE(357.4,"APO",LIST,PRNT,GROUP)) Q:GROUP="" D
15 .. S HDR=$P($G(^IBE(357.4,GROUP,0)),"^")
16 .. I HDR="BLANK" S HDR=""
17 .. S COUNT=COUNT+1,@ARY@(COUNT)="^"_HDR
18 .. S ORDER=""
19 .. F S ORDER=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER)) Q:ORDER="" D
20 ... S SLCTN=0
21 ... F S SLCTN=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN)) Q:'SLCTN D
22 .... S NODE=$G(^IBE(357.3,SLCTN,0))
23 .... S NODE2=$G(^IBE(357.3,SLCTN,2))
24 .... S NODE1=$G(^IBE(357.3,SLCTN,1,+$O(^IBE(357.3,SLCTN,1,"B",+TSUBCOL,0)),0))
25 .... ; -- return placeholders as headers when use as subheader
26 .... ; is yes and quit
27 .... I $P(NODE,"^",2),$P(NODE,"^",7)=1 D Q
28 ..... S COUNT=COUNT+1,@ARY@(COUNT)="^"_$P(NODE,"^",6)
29 .... ;
30 .... I $P(NODE1,"^")=TSUBCOL,$L($P(NODE1,"^",2)) S COUNT=COUNT+1,@ARY@(COUNT)=$P(NODE,"^")_"^"_$P(NODE1,"^",2)_"^^^^"_$P(NODE2,"^")_"^"_$P(NODE2,"^",3)_"^"_$P(NODE2,"^",4)_"^"_$P(NODE2,"^",2)
31 .... D MODLIST
32 Q
33 ;
34SUBCOL(LIST,TSUBCOL) ; -- finds the subcolumn containing the text
35 ; -- TSUBCOL passed by reference - used to return the subcolumn
36 ; LIST is the selection list to search
37 ;
38 ; -- refering to the data returned by the package interface,
39 ; piece 2 is usually the description
40 ;
41 N PI,SC
42 S TSUBCOL="",SC=0
43 S PI=$P($G(^IBE(357.6,+$P($G(^IBE(357.2,+LIST,0)),"^",11),0)),"^")
44 ;
45 F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC D
46 .Q:$P($G(^IBE(357.2,LIST,2,SC,0)),"^",4)=2 ;is a marking area
47 .I $P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)=2 S TSUBCOL=$P(^(0),"^") Q
48 .I TSUBCOL="",$P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)>2 S TSUBCOL=$P(^(0),"^") Q ; -- see if other than data piece two is text subcolumn
49 .;
50 .; -- utility for selecting blanks is exception
51 .I TSUBCOL="",PI="IBDF UTILITY FOR SELECTING BLANKS",$P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)=1 S TSUBCOL=$P(^(0),"^") Q
52 Q
53 ;
54F2(ARY) ; -- filter cpt code array to find only codes beginning with 992 and asssicated headers
55 ; -- Copy filtered array to from ibdtmp( to @ary@(
56 ;
57 N NODE,IBQUIT,COUNT
58 S (COUNT,IBQUIT)=0
59 ;
60 ;I INTRFACE'="DG SELECT CPT PROCEDURE CODES" S @ARY=IBDTMP K IBDTMP
61 ;
62 S NODE="" F S NODE=$O(IBDTMP(NODE),-1) Q:NODE="" I $E(IBDTMP(NODE),1,3)=992 D ;Q:IBQUIT ;comment out the q:ibquit if want from more than 1 list
63 .;
64 .S @ARY@(NODE)=IBDTMP(NODE),COUNT=COUNT+1 ;this is bottom of list
65 .;
66 .; -- process from bottom of list to header
67 .F S NODE=$O(IBDTMP(NODE),-1) Q:NODE="" D Q:IBQUIT
68 ..S IBQUIT=0
69 ..I $E(IBDTMP(NODE),1,3)=992 S @ARY@(NODE)=IBDTMP(NODE),COUNT=COUNT+1
70 ..I $P(IBDTMP(NODE),"^",1)="" S @ARY@(NODE)=IBDTMP(NODE),IBQUIT=1,COUNT=COUNT+1
71 I COUNT S @ARY@(0)=COUNT
72 Q
73 ;
74URH ; -- UnReferenced Headers (removal)
75 ; if a header doesn't have any data under it, then remove the header
76 N X,HDR
77 S X=0 F S X=$O(@ARY@(X)) Q:'X D
78 .I '$D(HDR),$P(@ARY@(X),"^",1)="" S HDR=X Q ;find a header
79 .I $P(@ARY@(X),"^",1)="" K HDR Q ; is item under header
80 .; -- patch 34 check if piece one below = null instead of positive
81 .I $D(HDR),$P(@ARY@(X),"^",1)="" K @ARY@(HDR) S COUNT=COUNT-1,HDR=X ;hdr doesn't have any items, kill hdr node and reset header to next header
82 .;I $D(HDR),$P(@ARY@(X),"^",1) K @ARY@(HDR) S COUNT=COUNT-1,HDR=X ;hdr doesn't have any items, kill hdr node and reset header to next header
83 I $D(HDR) S X=$O(@ARY@(""),-1) I $P(@ARY@(X),"^",1)="" K @ARY@(X) S COUNT=COUNT-1,HDR=X ;last item in list is a header
84 Q
85MODLIST ; return all CPT Modifiers if defined
86 ;
87 Q:$G(MODIFIER)'=1
88 N MCOUNT,MOD
89 Q:'$D(^IBE(357.3,SLCTN,3))
90 S MCOUNT=0
91 F MOD=0:0 S MOD=$O(^IBE(357.3,SLCTN,3,MOD)) Q:'MOD D
92 . S MCOUNT=MCOUNT+1
93 . S @ARY@(COUNT,"MODIFIER",MCOUNT)=$G(^IBE(357.3,SLCTN,3,MOD,0))
94 S:MCOUNT>0 @ARY@(COUNT,"MODIFIER",0)=MCOUNT
95 Q
Note: See TracBrowser for help on using the repository browser.