- IBDF18A1 ;ALB/CJM/AAS - ENCOUNTER FORM - utilities for PCE ;12-AUG-94
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, 1997
- ;
- COPYLIST(LIST,ARY,COUNT) ;
- ; -- copies the entries from LIST to @ARY, starting subscript at COUNT+1
- ;
- N SLCTN,NODE,NODE1,NODE2,TSUBCOL,GROUP,ORDER,HDR,PRNT
- ;
- D SUBCOL(LIST,.TSUBCOL) ;find the subcolumn containing the text
- ;
- S PRNT=""
- F S PRNT=$O(^IBE(357.4,"APO",LIST,PRNT)) Q:PRNT="" D
- . S GROUP=""
- . F S GROUP=$O(^IBE(357.4,"APO",LIST,PRNT,GROUP)) Q:GROUP="" D
- .. S HDR=$P($G(^IBE(357.4,GROUP,0)),"^")
- .. I HDR="BLANK" S HDR=""
- .. S COUNT=COUNT+1,@ARY@(COUNT)="^"_HDR
- .. S ORDER=""
- .. F S ORDER=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER)) Q:ORDER="" D
- ... S SLCTN=0
- ... F S SLCTN=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN)) Q:'SLCTN D
- .... S NODE=$G(^IBE(357.3,SLCTN,0))
- .... S NODE2=$G(^IBE(357.3,SLCTN,2))
- .... S NODE1=$G(^IBE(357.3,SLCTN,1,+$O(^IBE(357.3,SLCTN,1,"B",+TSUBCOL,0)),0))
- .... ; -- return placeholders as headers when use as subheader
- .... ; is yes and quit
- .... I $P(NODE,"^",2),$P(NODE,"^",7)=1 D Q
- ..... S COUNT=COUNT+1,@ARY@(COUNT)="^"_$P(NODE,"^",6)
- .... ;
- .... 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)
- .... D MODLIST
- Q
- ;
- SUBCOL(LIST,TSUBCOL) ; -- finds the subcolumn containing the text
- ; -- TSUBCOL passed by reference - used to return the subcolumn
- ; LIST is the selection list to search
- ;
- ; -- refering to the data returned by the package interface,
- ; piece 2 is usually the description
- ;
- N PI,SC
- S TSUBCOL="",SC=0
- S PI=$P($G(^IBE(357.6,+$P($G(^IBE(357.2,+LIST,0)),"^",11),0)),"^")
- ;
- F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC D
- .Q:$P($G(^IBE(357.2,LIST,2,SC,0)),"^",4)=2 ;is a marking area
- .I $P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)=2 S TSUBCOL=$P(^(0),"^") Q
- .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
- .;
- .; -- utility for selecting blanks is exception
- .I TSUBCOL="",PI="IBDF UTILITY FOR SELECTING BLANKS",$P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)=1 S TSUBCOL=$P(^(0),"^") Q
- Q
- ;
- F2(ARY) ; -- filter cpt code array to find only codes beginning with 992 and asssicated headers
- ; -- Copy filtered array to from ibdtmp( to @ary@(
- ;
- N NODE,IBQUIT,COUNT
- S (COUNT,IBQUIT)=0
- ;
- ;I INTRFACE'="DG SELECT CPT PROCEDURE CODES" S @ARY=IBDTMP K IBDTMP
- ;
- 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
- .;
- .S @ARY@(NODE)=IBDTMP(NODE),COUNT=COUNT+1 ;this is bottom of list
- .;
- .; -- process from bottom of list to header
- .F S NODE=$O(IBDTMP(NODE),-1) Q:NODE="" D Q:IBQUIT
- ..S IBQUIT=0
- ..I $E(IBDTMP(NODE),1,3)=992 S @ARY@(NODE)=IBDTMP(NODE),COUNT=COUNT+1
- ..I $P(IBDTMP(NODE),"^",1)="" S @ARY@(NODE)=IBDTMP(NODE),IBQUIT=1,COUNT=COUNT+1
- I COUNT S @ARY@(0)=COUNT
- Q
- ;
- URH ; -- UnReferenced Headers (removal)
- ; if a header doesn't have any data under it, then remove the header
- N X,HDR
- S X=0 F S X=$O(@ARY@(X)) Q:'X D
- .I '$D(HDR),$P(@ARY@(X),"^",1)="" S HDR=X Q ;find a header
- .I $P(@ARY@(X),"^",1)="" K HDR Q ; is item under header
- .; -- patch 34 check if piece one below = null instead of positive
- .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
- .;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
- 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
- Q
- MODLIST ; return all CPT Modifiers if defined
- ;
- Q:$G(MODIFIER)'=1
- N MCOUNT,MOD
- Q:'$D(^IBE(357.3,SLCTN,3))
- S MCOUNT=0
- F MOD=0:0 S MOD=$O(^IBE(357.3,SLCTN,3,MOD)) Q:'MOD D
- . S MCOUNT=MCOUNT+1
- . S @ARY@(COUNT,"MODIFIER",MCOUNT)=$G(^IBE(357.3,SLCTN,3,MOD,0))
- S:MCOUNT>0 @ARY@(COUNT,"MODIFIER",0)=MCOUNT
- Q
- IBDF18A1 ;ALB/CJM/AAS - ENCOUNTER FORM - utilities for PCE ;12-AUG-94
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, 1997
- +2 ;
- COPYLIST(LIST,ARY,COUNT) ;
- +1 ; -- copies the entries from LIST to @ARY, starting subscript at COUNT+1
- +2 ;
- +3 NEW SLCTN,NODE,NODE1,NODE2,TSUBCOL,GROUP,ORDER,HDR,PRNT
- +4 ;
- +5 ;find the subcolumn containing the text
- DO SUBCOL(LIST,.TSUBCOL)
- +6 ;
- +7 SET PRNT=""
- +8 FOR
- SET PRNT=$ORDER(^IBE(357.4,"APO",LIST,PRNT))
- IF PRNT=""
- QUIT
- Begin DoDot:1
- +9 SET GROUP=""
- +10 FOR
- SET GROUP=$ORDER(^IBE(357.4,"APO",LIST,PRNT,GROUP))
- IF GROUP=""
- QUIT
- Begin DoDot:2
- +11 SET HDR=$PIECE($GET(^IBE(357.4,GROUP,0)),"^")
- +12 IF HDR="BLANK"
- SET HDR=""
- +13 SET COUNT=COUNT+1
- SET @ARY@(COUNT)="^"_HDR
- +14 SET ORDER=""
- +15 FOR
- SET ORDER=$ORDER(^IBE(357.3,"APO",LIST,GROUP,ORDER))
- IF ORDER=""
- QUIT
- Begin DoDot:3
- +16 SET SLCTN=0
- +17 FOR
- SET SLCTN=$ORDER(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN))
- IF 'SLCTN
- QUIT
- Begin DoDot:4
- +18 SET NODE=$GET(^IBE(357.3,SLCTN,0))
- +19 SET NODE2=$GET(^IBE(357.3,SLCTN,2))
- +20 SET NODE1=$GET(^IBE(357.3,SLCTN,1,+$ORDER(^IBE(357.3,SLCTN,1,"B",+TSUBCOL,0)),0))
- +21 ; -- return placeholders as headers when use as subheader
- +22 ; is yes and quit
- +23 IF $PIECE(NODE,"^",2)
- IF $PIECE(NODE,"^",7)=1
- Begin DoDot:5
- +24 SET COUNT=COUNT+1
- SET @ARY@(COUNT)="^"_$PIECE(NODE,"^",6)
- End DoDot:5
- QUIT
- +25 ;
- +26 IF $PIECE(NODE1,"^")=TSUBCOL
- IF $LENGTH($PIECE(NODE1,"^",2))
- SET COUNT=COUNT+1
- SET @ARY@(COUNT)=$PIECE(NODE,"^")_"^"_$PIECE(NODE1,"^",2)_"^^^^"_$PIECE(NODE2,"^")_"^"_$PIECE(NODE2,"^",3)_"^"_$PIECE(NODE2,"^",4)_"^"_$PIECE(NODE2,"^",2)
- +27 DO MODLIST
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +28 QUIT
- +29 ;
- SUBCOL(LIST,TSUBCOL) ; -- finds the subcolumn containing the text
- +1 ; -- TSUBCOL passed by reference - used to return the subcolumn
- +2 ; LIST is the selection list to search
- +3 ;
- +4 ; -- refering to the data returned by the package interface,
- +5 ; piece 2 is usually the description
- +6 ;
- +7 NEW PI,SC
- +8 SET TSUBCOL=""
- SET SC=0
- +9 SET PI=$PIECE($GET(^IBE(357.6,+$PIECE($GET(^IBE(357.2,+LIST,0)),"^",11),0)),"^")
- +10 ;
- +11 FOR
- SET SC=$ORDER(^IBE(357.2,LIST,2,SC))
- IF 'SC
- QUIT
- Begin DoDot:1
- +12 ;is a marking area
- IF $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",4)=2
- QUIT
- +13 IF $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",5)=2
- SET TSUBCOL=$PIECE(^(0),"^")
- QUIT
- +14 ; -- see if other than data piece two is text subcolumn
- IF TSUBCOL=""
- IF $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",5)>2
- SET TSUBCOL=$PIECE(^(0),"^")
- QUIT
- +15 ;
- +16 ; -- utility for selecting blanks is exception
- +17 IF TSUBCOL=""
- IF PI="IBDF UTILITY FOR SELECTING BLANKS"
- IF $PIECE($GET(^IBE(357.2,LIST,2,SC,0)),"^",5)=1
- SET TSUBCOL=$PIECE(^(0),"^")
- QUIT
- End DoDot:1
- +18 QUIT
- +19 ;
- F2(ARY) ; -- filter cpt code array to find only codes beginning with 992 and asssicated headers
- +1 ; -- Copy filtered array to from ibdtmp( to @ary@(
- +2 ;
- +3 NEW NODE,IBQUIT,COUNT
- +4 SET (COUNT,IBQUIT)=0
- +5 ;
- +6 ;I INTRFACE'="DG SELECT CPT PROCEDURE CODES" S @ARY=IBDTMP K IBDTMP
- +7 ;
- +8 ;Q:IBQUIT ;comment out the q:ibquit if want from more than 1 list
- SET NODE=""
- FOR
- SET NODE=$ORDER(IBDTMP(NODE),-1)
- IF NODE=""
- QUIT
- IF $EXTRACT(IBDTMP(NODE),1,3)=992
- Begin DoDot:1
- +9 ;
- +10 ;this is bottom of list
- SET @ARY@(NODE)=IBDTMP(NODE)
- SET COUNT=COUNT+1
- +11 ;
- +12 ; -- process from bottom of list to header
- +13 FOR
- SET NODE=$ORDER(IBDTMP(NODE),-1)
- IF NODE=""
- QUIT
- Begin DoDot:2
- +14 SET IBQUIT=0
- +15 IF $EXTRACT(IBDTMP(NODE),1,3)=992
- SET @ARY@(NODE)=IBDTMP(NODE)
- SET COUNT=COUNT+1
- +16 IF $PIECE(IBDTMP(NODE),"^",1)=""
- SET @ARY@(NODE)=IBDTMP(NODE)
- SET IBQUIT=1
- SET COUNT=COUNT+1
- End DoDot:2
- IF IBQUIT
- QUIT
- End DoDot:1
- +17 IF COUNT
- SET @ARY@(0)=COUNT
- +18 QUIT
- +19 ;
- URH ; -- UnReferenced Headers (removal)
- +1 ; if a header doesn't have any data under it, then remove the header
- +2 NEW X,HDR
- +3 SET X=0
- FOR
- SET X=$ORDER(@ARY@(X))
- IF 'X
- QUIT
- Begin DoDot:1
- +4 ;find a header
- IF '$DATA(HDR)
- IF $PIECE(@ARY@(X),"^",1)=""
- SET HDR=X
- QUIT
- +5 ; is item under header
- IF $PIECE(@ARY@(X),"^",1)=""
- KILL HDR
- QUIT
- +6 ; -- patch 34 check if piece one below = null instead of positive
- +7 ;hdr doesn't have any items, kill hdr node and reset header to next header
- IF $DATA(HDR)
- IF $PIECE(@ARY@(X),"^",1)=""
- KILL @ARY@(HDR)
- SET COUNT=COUNT-1
- SET HDR=X
- +8 ;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
- End DoDot:1
- +9 ;last item in list is a header
- IF $DATA(HDR)
- SET X=$ORDER(@ARY@(""),-1)
- IF $PIECE(@ARY@(X),"^",1)=""
- KILL @ARY@(X)
- SET COUNT=COUNT-1
- SET HDR=X
- +10 QUIT
- MODLIST ; return all CPT Modifiers if defined
- +1 ;
- +2 IF $GET(MODIFIER)'=1
- QUIT
- +3 NEW MCOUNT,MOD
- +4 IF '$DATA(^IBE(357.3,SLCTN,3))
- QUIT
- +5 SET MCOUNT=0
- +6 FOR MOD=0:0
- SET MOD=$ORDER(^IBE(357.3,SLCTN,3,MOD))
- IF 'MOD
- QUIT
- Begin DoDot:1
- +7 SET MCOUNT=MCOUNT+1
- +8 SET @ARY@(COUNT,"MODIFIER",MCOUNT)=$GET(^IBE(357.3,SLCTN,3,MOD,0))
- End DoDot:1
- +9 IF MCOUNT>0
- SET @ARY@(COUNT,"MODIFIER",0)=MCOUNT
- +10 QUIT
