IBDFQSL2 ;ALB/CJM/AAS/MAF - ENCOUNTER FORM - Quick selection edit (cont.);12-Jun-95
;;3.0;AUTOMATED INFO COLLECTION SYS;**34**;APR 24, 1997
;
GETLST(FORM,BLOCK,LIST,INTRFACE,ARY,FILTER,COUNT) ; -- returns any specified selection list for a clinic
; -- input FORM = ien of entry in 357
; BLOCK = ien of entry in 357.1
; LIST = ien of entry in 357.2
; INTRFACE = name of selection list in package interface file
; ARY = name of array to return list in
; FILTER = predefined filters (optional, default = 1)
; 1 = must be selection list
; 2 = only visit cpts on list
;
; -- output The format of the returned array is as follows
; @ARY@(0) = count of array element (0 of nothing found)
; @ARY@(1) = ^group header
; @ARY@(2) = problem ien or cpt or icd code^user defined text
; @ARY@(3) = problem ien or cpt or icd code^used defined text
; @ARY@(k) = ^next group header
; @ARY@(k+1) = problem ien or cpt or icd code^user define text
;
Q:'FORM!('BLOCK)!('LIST)!('INTRFACE)
N OLDARY,IBDTMP
S COUNT=$G(COUNT,0)
I $G(FILTER)<1 S FILTER=1 ;default value=1
I FILTER>1 S OLDARY=ARY,ARY="IBDTMP"
S @ARY@(0)=+$G(@ARY@(0))
D COPYLIST(LIST,ARY,.COUNT)
S @ARY@(0)=COUNT
I FILTER=2 D F2^IBDF18A1(OLDARY)
Q
;
COPYLIST(LIST,ARY,COUNT) ;copies the entries from LIST to @ARY, starting subscript at COUNT+1
;
N SLCTN,SUBCOL,TEXT,IEN,NODE,TSUBCOL,NODE,GROUP,ORDER,HDR,GRPORDR
;
D SUBCOL^IBDF18A1(LIST,.TSUBCOL) ;find the subcolumn containing the text
;
S GRPORDR=""
F S GRPORDR=$O(^IBE(357.4,"APO",LIST,GRPORDR)) Q:GRPORDR="" D
.S GROUP=0
.F S GROUP=$O(^IBE(357.4,"APO",LIST,GRPORDR,GROUP)) Q:'GROUP D
..S HDR=$P($G(^IBE(357.4,GROUP,0)),"^") ;I HDR="BLANK" S HDR="" If don't want to print BLANK group
..S COUNT=COUNT+1,@ARY@(COUNT)="^"_HDR_"^^^"_GROUP_"^"_GRPORDR
..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 IEN=$P(NODE,"^")
....S SUBCOL=$O(^IBE(357.3,SLCTN,1,"B",+TSUBCOL,0))
....;
....I 'SUBCOL D Q ;placeholders
.....S TEXT=$S($P(NODE,"^",6)?1E.E:$P(NODE,"^",6),1:"BLANK")
.....S COUNT=COUNT+1
.....S @ARY@(COUNT)=" "_"^"_TEXT_"^"_LIST_"^"_SLCTN_"^"_GROUP_"^"_ORDER Q
....;
....S NODE=$G(^IBE(357.3,SLCTN,1,SUBCOL,0))
....S:$P(NODE,"^")=TSUBCOL TEXT=$P(NODE,"^",2)
....;
....I $L(TEXT) S COUNT=COUNT+1,@ARY@(COUNT)=IEN_"^"_TEXT_"^"_LIST_"^"_SLCTN_"^"_GROUP_"^"_ORDER Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFQSL2 2717 printed Dec 13, 2024@02:53:16 Page 2
IBDFQSL2 ;ALB/CJM/AAS/MAF - ENCOUNTER FORM - Quick selection edit (cont.);12-Jun-95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**34**;APR 24, 1997
+2 ;
GETLST(FORM,BLOCK,LIST,INTRFACE,ARY,FILTER,COUNT) ; -- returns any specified selection list for a clinic
+1 ; -- input FORM = ien of entry in 357
+2 ; BLOCK = ien of entry in 357.1
+3 ; LIST = ien of entry in 357.2
+4 ; INTRFACE = name of selection list in package interface file
+5 ; ARY = name of array to return list in
+6 ; FILTER = predefined filters (optional, default = 1)
+7 ; 1 = must be selection list
+8 ; 2 = only visit cpts on list
+9 ;
+10 ; -- output The format of the returned array is as follows
+11 ; @ARY@(0) = count of array element (0 of nothing found)
+12 ; @ARY@(1) = ^group header
+13 ; @ARY@(2) = problem ien or cpt or icd code^user defined text
+14 ; @ARY@(3) = problem ien or cpt or icd code^used defined text
+15 ; @ARY@(k) = ^next group header
+16 ; @ARY@(k+1) = problem ien or cpt or icd code^user define text
+17 ;
+18 if 'FORM!('BLOCK)!('LIST)!('INTRFACE)
QUIT
+19 NEW OLDARY,IBDTMP
+20 SET COUNT=$GET(COUNT,0)
+21 ;default value=1
IF $GET(FILTER)<1
SET FILTER=1
+22 IF FILTER>1
SET OLDARY=ARY
SET ARY="IBDTMP"
+23 SET @ARY@(0)=+$GET(@ARY@(0))
+24 DO COPYLIST(LIST,ARY,.COUNT)
+25 SET @ARY@(0)=COUNT
+26 IF FILTER=2
DO F2^IBDF18A1(OLDARY)
+27 QUIT
+28 ;
COPYLIST(LIST,ARY,COUNT) ;copies the entries from LIST to @ARY, starting subscript at COUNT+1
+1 ;
+2 NEW SLCTN,SUBCOL,TEXT,IEN,NODE,TSUBCOL,NODE,GROUP,ORDER,HDR,GRPORDR
+3 ;
+4 ;find the subcolumn containing the text
DO SUBCOL^IBDF18A1(LIST,.TSUBCOL)
+5 ;
+6 SET GRPORDR=""
+7 FOR
SET GRPORDR=$ORDER(^IBE(357.4,"APO",LIST,GRPORDR))
if GRPORDR=""
QUIT
Begin DoDot:1
+8 SET GROUP=0
+9 FOR
SET GROUP=$ORDER(^IBE(357.4,"APO",LIST,GRPORDR,GROUP))
if 'GROUP
QUIT
Begin DoDot:2
+10 ;I HDR="BLANK" S HDR="" If don't want to print BLANK group
SET HDR=$PIECE($GET(^IBE(357.4,GROUP,0)),"^")
+11 SET COUNT=COUNT+1
SET @ARY@(COUNT)="^"_HDR_"^^^"_GROUP_"^"_GRPORDR
+12 SET ORDER=""
+13 FOR
SET ORDER=$ORDER(^IBE(357.3,"APO",LIST,GROUP,ORDER))
if ORDER=""
QUIT
Begin DoDot:3
+14 SET SLCTN=0
+15 FOR
SET SLCTN=$ORDER(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN))
if 'SLCTN
QUIT
Begin DoDot:4
+16 SET NODE=$GET(^IBE(357.3,SLCTN,0))
+17 SET IEN=$PIECE(NODE,"^")
+18 SET SUBCOL=$ORDER(^IBE(357.3,SLCTN,1,"B",+TSUBCOL,0))
+19 ;
+20 ;placeholders
IF 'SUBCOL
Begin DoDot:5
+21 SET TEXT=$SELECT($PIECE(NODE,"^",6)?1E.E:$PIECE(NODE,"^",6),1:"BLANK")
+22 SET COUNT=COUNT+1
+23 SET @ARY@(COUNT)=" "_"^"_TEXT_"^"_LIST_"^"_SLCTN_"^"_GROUP_"^"_ORDER
QUIT
End DoDot:5
QUIT
+24 ;
+25 SET NODE=$GET(^IBE(357.3,SLCTN,1,SUBCOL,0))
+26 if $PIECE(NODE,"^")=TSUBCOL
SET TEXT=$PIECE(NODE,"^",2)
+27 ;
+28 IF $LENGTH(TEXT)
SET COUNT=COUNT+1
SET @ARY@(COUNT)=IEN_"^"_TEXT_"^"_LIST_"^"_SLCTN_"^"_GROUP_"^"_ORDER
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
