IBDF18 ;A;B/CJM - ENCOUNTER FORM - utilities for Problem List ;15OCT93
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
GETFORM() ;allows the user to select an encounter form with a Clinic Common Problem List
;returns <the form ien, or 0 if none selected>^<form name>
N FORM,LIST,QUIT,ANS
S (LIST,QUIT)=0 F D Q:QUIT
.S FORM=$$SLCTFORM^IBDFU4(0)
.I 'FORM S QUIT=1 Q
.D FIND(FORM,0,.LIST,0)
.I LIST S QUIT=1 Q
.W !,"The form you selected doesn't contain a Clinic Common Problem List!",!,"Do you want to select another form? "
.R ANS:DTIME
.S:'$T!(ANS="")!(ANS["^")!(ANS["N")!(ANS["n") QUIT=1,FORM=0
Q FORM_"^"_$P($G(^IBE(357,FORM,0)),"^")
;
;
COPYFORM(FORM,ARY) ;creates a list of problem groups and problems found in FORM on the list of clinic common problems
;returns the length of the returned list
;FORM is the ien of an encounter form
;@ARY is the array where the list should be placed
;each problem will have the format 'problem ien^problem text'
;each group will have the format '^header text to display (could be null)'
;following each group will be the problems on it
;
;the ruturned list will look like this:
;@ARY@(1)=^group header
;@ARY@(2)=problem ien^problem text
;@ARY@(3)=problem ien^problem text
;
;
;@ARY@(k)=^next group header
;@ARY@(k+1)=problem ien^problem text
;....
;
Q:'$G(FORM) 0
Q:'$L($G(ARY)) 0
N BLOCK,LIST,INTRFACE,COUNT
S (BLOCK,LIST,INTRFACE,COUNT)=0
F D FIND(FORM,.BLOCK,.LIST,.INTRFACE) Q:'LIST D COPYLIST(LIST,ARY,.COUNT)
Q COUNT
;
COPYLIST(LIST,ARY,COUNT) ;copies the entries from LIST to @ARY, starting subscript at COUNT+1
;
N SLCTN,SUBCOL,TEXT,IEN,NODE,TSUBCOL,NOTREAL,NODE,GROUP,ORDER,HDR
;
D SUBCOL(LIST,.TSUBCOL) ;find the subcolumn containing the text
;don't bother returning list of problems if there is no subcolumn containing the problem text
Q:'$G(TSUBCOL)
;
S GROUP=0 F S GROUP=$O(^IBE(357.3,"APO",LIST,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="" 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)),IEN=$P(NODE,"^"),NOTREAL=$P(NODE,"^",2)
..Q:'IEN!(NOTREAL)
..S SUBCOL=$O(^IBE(357.3,SLCTN,1,"B",TSUBCOL,0)) Q:'SUBCOL 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 Q
Q
;
;
SUBCOL(LIST,TSUBCOL) ;finds the subcolumn containing the text
;TSUBCOL should be passed by reference - used to return the subcolumn
;LIST is the selection list to search
S TSUBCOL=""
;
N SC,PIECE,NODE S SC=0
;
;refering to the data returned by the package interface, piece 2 is the description
F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC S NODE=$G(^IBE(357.2,LIST,2,SC,0)),PIECE=$P(NODE,"^",5) I PIECE=2 S TSUBCOL=$P(NODE,"^") Q
Q
;
FIND(FORM,BLK,LIST,INTRFACE) ;finds the block & list containing the Clinic Common Problem List
N INTRFACE,QUIT
S BLK=+$G(BLK),LIST=+$G(LIST),INTRFACE=+$G(INTRFACE)
;
;if not already found,find the package interface for selecting PROBLEMS
I 'INTRFACE S INTRFACE=$O(^IBE(357.6,"B","GMP SELECT CLINIC COMMON PROBL",0))
I 'INTRFACE S (BLK,LIST)=0 QUIT
;
I BLK D
.F S LIST=$O(^IBE(357.2,"C",BLK,LIST)) Q:'LIST I $P($G(^IBE(357.2,LIST,0)),"^",11)=INTRFACE Q
I BLK,LIST QUIT
S QUIT=0
F S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK D Q:QUIT
.S LIST=0 F S LIST=$O(^IBE(357.2,"C",BLK,LIST)) Q:'LIST I $P($G(^IBE(357.2,LIST,0)),"^",11)=INTRFACE S QUIT=1 Q
I 'BLK!('LIST) S (BLK,LIST)=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF18 3703 printed Dec 13, 2024@02:50:49 Page 2
IBDF18 ;A;B/CJM - ENCOUNTER FORM - utilities for Problem List ;15OCT93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
GETFORM() ;allows the user to select an encounter form with a Clinic Common Problem List
+1 ;returns <the form ien, or 0 if none selected>^<form name>
+2 NEW FORM,LIST,QUIT,ANS
+3 SET (LIST,QUIT)=0
FOR
Begin DoDot:1
+4 SET FORM=$$SLCTFORM^IBDFU4(0)
+5 IF 'FORM
SET QUIT=1
QUIT
+6 DO FIND(FORM,0,.LIST,0)
+7 IF LIST
SET QUIT=1
QUIT
+8 WRITE !,"The form you selected doesn't contain a Clinic Common Problem List!",!,"Do you want to select another form? "
+9 READ ANS:DTIME
+10 if '$TEST!(ANS="")!(ANS["^")!(ANS["N")!(ANS["n")
SET QUIT=1
SET FORM=0
End DoDot:1
if QUIT
QUIT
+11 QUIT FORM_"^"_$PIECE($GET(^IBE(357,FORM,0)),"^")
+12 ;
+13 ;
COPYFORM(FORM,ARY) ;creates a list of problem groups and problems found in FORM on the list of clinic common problems
+1 ;returns the length of the returned list
+2 ;FORM is the ien of an encounter form
+3 ;@ARY is the array where the list should be placed
+4 ;each problem will have the format 'problem ien^problem text'
+5 ;each group will have the format '^header text to display (could be null)'
+6 ;following each group will be the problems on it
+7 ;
+8 ;the ruturned list will look like this:
+9 ;@ARY@(1)=^group header
+10 ;@ARY@(2)=problem ien^problem text
+11 ;@ARY@(3)=problem ien^problem text
+12 ;
+13 ;
+14 ;@ARY@(k)=^next group header
+15 ;@ARY@(k+1)=problem ien^problem text
+16 ;....
+17 ;
+18 if '$GET(FORM)
QUIT 0
+19 if '$LENGTH($GET(ARY))
QUIT 0
+20 NEW BLOCK,LIST,INTRFACE,COUNT
+21 SET (BLOCK,LIST,INTRFACE,COUNT)=0
+22 FOR
DO FIND(FORM,.BLOCK,.LIST,.INTRFACE)
if 'LIST
QUIT
DO COPYLIST(LIST,ARY,.COUNT)
+23 QUIT COUNT
+24 ;
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,NOTREAL,NODE,GROUP,ORDER,HDR
+3 ;
+4 ;find the subcolumn containing the text
DO SUBCOL(LIST,.TSUBCOL)
+5 ;don't bother returning list of problems if there is no subcolumn containing the problem text
+6 if '$GET(TSUBCOL)
QUIT
+7 ;
+8 SET GROUP=0
FOR
SET GROUP=$ORDER(^IBE(357.3,"APO",LIST,GROUP))
if 'GROUP
QUIT
Begin DoDot:1
+9 SET HDR=$PIECE($GET(^IBE(357.4,GROUP,0)),"^")
IF HDR="BLANK"
SET HDR=""
+10 SET COUNT=COUNT+1
SET @ARY@(COUNT)="^"_HDR
+11 SET ORDER=""
FOR
SET ORDER=$ORDER(^IBE(357.3,"APO",LIST,GROUP,ORDER))
if ORDER=""
QUIT
SET SLCTN=0
FOR
SET SLCTN=$ORDER(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN))
if 'SLCTN
QUIT
Begin DoDot:2
+12 SET NODE=$GET(^IBE(357.3,SLCTN,0))
SET IEN=$PIECE(NODE,"^")
SET NOTREAL=$PIECE(NODE,"^",2)
+13 if 'IEN!(NOTREAL)
QUIT
+14 SET SUBCOL=$ORDER(^IBE(357.3,SLCTN,1,"B",TSUBCOL,0))
if 'SUBCOL
QUIT
SET NODE=$GET(^IBE(357.3,SLCTN,1,SUBCOL,0))
if $PIECE(NODE,"^")=TSUBCOL
SET TEXT=$PIECE(NODE,"^",2)
IF $LENGTH(TEXT)
SET COUNT=COUNT+1
SET @ARY@(COUNT)=IEN_"^"_TEXT
QUIT
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
+17 ;
SUBCOL(LIST,TSUBCOL) ;finds the subcolumn containing the text
+1 ;TSUBCOL should be passed by reference - used to return the subcolumn
+2 ;LIST is the selection list to search
+3 SET TSUBCOL=""
+4 ;
+5 NEW SC,PIECE,NODE
SET SC=0
+6 ;
+7 ;refering to the data returned by the package interface, piece 2 is the description
+8 FOR
SET SC=$ORDER(^IBE(357.2,LIST,2,SC))
if 'SC
QUIT
SET NODE=$GET(^IBE(357.2,LIST,2,SC,0))
SET PIECE=$PIECE(NODE,"^",5)
IF PIECE=2
SET TSUBCOL=$PIECE(NODE,"^")
QUIT
+9 QUIT
+10 ;
FIND(FORM,BLK,LIST,INTRFACE) ;finds the block & list containing the Clinic Common Problem List
+1 NEW INTRFACE,QUIT
+2 SET BLK=+$GET(BLK)
SET LIST=+$GET(LIST)
SET INTRFACE=+$GET(INTRFACE)
+3 ;
+4 ;if not already found,find the package interface for selecting PROBLEMS
+5 IF 'INTRFACE
SET INTRFACE=$ORDER(^IBE(357.6,"B","GMP SELECT CLINIC COMMON PROBL",0))
+6 IF 'INTRFACE
SET (BLK,LIST)=0
QUIT
+7 ;
+8 IF BLK
Begin DoDot:1
+9 FOR
SET LIST=$ORDER(^IBE(357.2,"C",BLK,LIST))
if 'LIST
QUIT
IF $PIECE($GET(^IBE(357.2,LIST,0)),"^",11)=INTRFACE
QUIT
End DoDot:1
+10 IF BLK
IF LIST
QUIT
+11 SET QUIT=0
+12 FOR
SET BLK=$ORDER(^IBE(357.1,"C",FORM,BLK))
if 'BLK
QUIT
Begin DoDot:1
+13 SET LIST=0
FOR
SET LIST=$ORDER(^IBE(357.2,"C",BLK,LIST))
if 'LIST
QUIT
IF $PIECE($GET(^IBE(357.2,LIST,0)),"^",11)=INTRFACE
SET QUIT=1
QUIT
End DoDot:1
if QUIT
QUIT
+14 IF 'BLK!('LIST)
SET (BLK,LIST)=0
+15 QUIT
