- 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
- 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
