Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDF18

IBDF18.m

Go to the documentation of this file.
  1. IBDF18 ;A;B/CJM - ENCOUNTER FORM - utilities for Problem List ;15OCT93
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. ;
  1. 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>
  1. N FORM,LIST,QUIT,ANS
  1. S (LIST,QUIT)=0 F D Q:QUIT
  1. .S FORM=$$SLCTFORM^IBDFU4(0)
  1. .I 'FORM S QUIT=1 Q
  1. .D FIND(FORM,0,.LIST,0)
  1. .I LIST S QUIT=1 Q
  1. .W !,"The form you selected doesn't contain a Clinic Common Problem List!",!,"Do you want to select another form? "
  1. .R ANS:DTIME
  1. .S:'$T!(ANS="")!(ANS["^")!(ANS["N")!(ANS["n") QUIT=1,FORM=0
  1. Q FORM_"^"_$P($G(^IBE(357,FORM,0)),"^")
  1. ;
  1. ;
  1. 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
  1. ;FORM is the ien of an encounter form
  1. ;@ARY is the array where the list should be placed
  1. ;each problem will have the format 'problem ien^problem text'
  1. ;each group will have the format '^header text to display (could be null)'
  1. ;following each group will be the problems on it
  1. ;
  1. ;the ruturned list will look like this:
  1. ;@ARY@(1)=^group header
  1. ;@ARY@(2)=problem ien^problem text
  1. ;@ARY@(3)=problem ien^problem text
  1. ;
  1. ;
  1. ;@ARY@(k)=^next group header
  1. ;@ARY@(k+1)=problem ien^problem text
  1. ;....
  1. ;
  1. Q:'$G(FORM) 0
  1. Q:'$L($G(ARY)) 0
  1. N BLOCK,LIST,INTRFACE,COUNT
  1. S (BLOCK,LIST,INTRFACE,COUNT)=0
  1. F D FIND(FORM,.BLOCK,.LIST,.INTRFACE) Q:'LIST D COPYLIST(LIST,ARY,.COUNT)
  1. Q COUNT
  1. ;
  1. COPYLIST(LIST,ARY,COUNT) ;copies the entries from LIST to @ARY, starting subscript at COUNT+1
  1. ;
  1. N SLCTN,SUBCOL,TEXT,IEN,NODE,TSUBCOL,NOTREAL,NODE,GROUP,ORDER,HDR
  1. ;
  1. D SUBCOL(LIST,.TSUBCOL) ;find the subcolumn containing the text
  1. ;don't bother returning list of problems if there is no subcolumn containing the problem text
  1. Q:'$G(TSUBCOL)
  1. ;
  1. S GROUP=0 F S GROUP=$O(^IBE(357.3,"APO",LIST,GROUP)) Q:'GROUP D
  1. .S HDR=$P($G(^IBE(357.4,GROUP,0)),"^") I HDR="BLANK" S HDR=""
  1. .S COUNT=COUNT+1,@ARY@(COUNT)="^"_HDR
  1. .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
  1. ..S NODE=$G(^IBE(357.3,SLCTN,0)),IEN=$P(NODE,"^"),NOTREAL=$P(NODE,"^",2)
  1. ..Q:'IEN!(NOTREAL)
  1. ..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
  1. Q
  1. ;
  1. ;
  1. SUBCOL(LIST,TSUBCOL) ;finds the subcolumn containing the text
  1. ;TSUBCOL should be passed by reference - used to return the subcolumn
  1. ;LIST is the selection list to search
  1. S TSUBCOL=""
  1. ;
  1. N SC,PIECE,NODE S SC=0
  1. ;
  1. ;refering to the data returned by the package interface, piece 2 is the description
  1. 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
  1. Q
  1. ;
  1. FIND(FORM,BLK,LIST,INTRFACE) ;finds the block & list containing the Clinic Common Problem List
  1. N INTRFACE,QUIT
  1. S BLK=+$G(BLK),LIST=+$G(LIST),INTRFACE=+$G(INTRFACE)
  1. ;
  1. ;if not already found,find the package interface for selecting PROBLEMS
  1. I 'INTRFACE S INTRFACE=$O(^IBE(357.6,"B","GMP SELECT CLINIC COMMON PROBL",0))
  1. I 'INTRFACE S (BLK,LIST)=0 QUIT
  1. ;
  1. I BLK D
  1. .F S LIST=$O(^IBE(357.2,"C",BLK,LIST)) Q:'LIST I $P($G(^IBE(357.2,LIST,0)),"^",11)=INTRFACE Q
  1. I BLK,LIST QUIT
  1. S QUIT=0
  1. F S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK D Q:QUIT
  1. .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
  1. I 'BLK!('LIST) S (BLK,LIST)=0
  1. Q