- 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 Feb 19, 2025@00:17:14 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