IBDF18A1 ;ALB/CJM/AAS - ENCOUNTER FORM - utilities for PCE ;12-AUG-94
;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38,69**;APR 24, 1997;Build 2
;
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)
.... ;IBD*3*69 - Add Quantity to 3rd piece of array
.... I $P(NODE1,"^")=TSUBCOL,$L($P(NODE1,"^",2)) S COUNT=COUNT+1,@ARY@(COUNT)=$P(NODE,"^")_"^"_$P(NODE1,"^",2)_"^"_$P(NODE,"^",9)_"^^^"_$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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF18A1 4257 printed Apr 09, 2024@21:59:37 Page 2
IBDF18A1 ;ALB/CJM/AAS - ENCOUNTER FORM - utilities for PCE ;12-AUG-94
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38,69**;APR 24, 1997;Build 2
+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 ;IBD*3*69 - Add Quantity to 3rd piece of array
+26 IF $PIECE(NODE1,"^")=TSUBCOL
IF $LENGTH($PIECE(NODE1,"^",2))
SET COUNT=COUNT+1
SET @ARY@(COUNT)=$PIECE(NODE,"^")_"^"_$PIECE(NODE1,"^",2)_"^"_$PIECE(NODE,"^",9)_"^^^"_$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
