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