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

IBDFCMP.m

Go to the documentation of this file. 
  1. IBDFCMP ;ALB/MAF - AICS list of components on a form ; 29-JUL-96
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. START K XQORS,VALMEVL D EN^VALM("IBDF FORM COMPONENTS")
  1.  Q
  1. INIT ;
  1. % N I,J,X,Y,DIR,DIRUT,DTOUT,DUOUT,IBDF,IBDPAG,IBDPDT,IBDOJB,IBQUIT,QLFR,RULE,IBDFALL
  1.  I '$D(DT) D DT^DICRW
  1.  D HOME^%ZIS
  1.  W !!,"Display Form Components",!!
  1.  ;
  1.  ; -- ask for form id
  1.  D END
  1.  S DIR("?")="Enter the Encounter Form Name you want to review."
  1.  S DIR(0)="PO^357:AEQM",DIR("A")="Select Encounter Form" D ^DIR K DIR,DA,DR,DIC
  1.  I $D(DIRUT) S VALMBCK="Q",VALMQUIT=1 Q
  1.  S IBDFIFN=+Y
  1. INIT1 S IBDCNT1=0,IBDCNT=0,VALMCNT=0
  1.  D DQ
  1.  ;
  1. STRTQ G:$G(IBQUIT) END ;D PAUSE^IBDFDE
  1.  Q
  1.  ;
  1. DQ ; -- entry point to list contents of one form,  
  1.  ;    Input IBDFIFN := pointer to Encounter Form (357)
  1.  ;
  1.  S IBQUIT=0
  1.  I '$D(^TMP("FORM-OBJ",$J,IBDFIFN,0)) S IBDFALL=1 D FRMLSTI^IBDFRPC(.IBDOBJ,IBDFIFN,"",1,IBDFALL) M ^TMP("FORM-OBJ",$J,IBDFIFN)=IBDOBJ K IBDOBJ
  1.  I $D(^TMP("FORM-OBJ",$J,IBDFIFN,0)),^TMP("FORM-OBJ",$J,IBDFIFN,0)'>0 D NUL Q
  1.  D LISTOB
  1.  Q
  1.  ;
  1. LISTOB ; -- list items available for input on a form
  1.  N IBDFOLDB
  1.  S IBDFOLDB=0
  1.  S I=0 F  S I=$O(^TMP("FORM-OBJ",$J,IBDFIFN,I)) Q:I=""!(IBQUIT)  D
  1.  .S IBDOBJ=$G(^TMP("FORM-OBJ",$J,IBDFIFN,I))
  1.  .S IBDF("PI")=+$P(IBDOBJ,"^",2),IBDF("TYPE")=$P(IBDOBJ,"^",5)
  1.  .S IBDF("IEN")=+$P(IBDOBJ,"^",6),IBDF("VITAL")=$P(IBDOBJ,"^",7)
  1.  .S IBDF("BROW")=+$P(IBDOBJ,"^",10)+1,IBDF("BCOL")=+$P(IBDOBJ,"^",11)+1
  1.  .S IBDF("BLK")=+$P(IBDOBJ,"^",9),IBDF("BNAME")=$P($G(^IBE(357.1,IBDF("BLK"),0)),"^"),IBDF("BNODE")=$G(^IBE(357.1,IBDF("BLK"),0))
  1.  .S IBDF("HT")=$P(IBDF("BNODE"),"^",7)
  1.  .S IBDF("WDTH")=$P(IBDF("BNODE"),"^",6)
  1.  .S IBDF("TKO")=$P(IBDF("BNODE"),"^",14)
  1.  .I IBDFOLDB'=$P(IBDOBJ,"^",9) S IBDFFLAG=0
  1.  .I 'IBDFFLAG D
  1.  ..S X=""
  1.  ..S IBDFFLAG=1,IBDFOLDB=$P(IBDOBJ,"^",9)
  1.  ..S IBDCNT1=IBDCNT1+1
  1.  ..S X=$$SETSTR^VALM1(X,X,1,80) D TMP
  1.  ..S X=""
  1.  ..S IBDVAL=IBDCNT1_") "
  1.  ..S X=$$SETSTR^VALM1(IBDVAL,X,1,4)
  1.  ..S X=$$SETSTR^VALM1($P(IBDF("BNAME"),"^",1),X,5,40) D TMP,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
  1.  ..S IBBLOCK(IBDCNT1)=IBDFIFN_"^"_IBDCNT_"^"_IBDOBJ
  1.  ..S X="",X=$$SETSTR^VALM1($$LOWER^VALM1("  STARTING ROW: "),X,1,16)
  1.  ..S IBDVAL=$S(IBDF("BROW"):IBDF("BROW"),1:"")
  1.  ..S X=$$SETSTR^VALM1($J(IBDVAL,3),X,17,3)
  1.  ..S X=$$SETSTR^VALM1($$LOWER^VALM1("STARTING COLUMN: "),X,49,17)
  1.  ..S IBDVAL=$S(IBDF("BCOL"):IBDF("BCOL"),1:"")
  1.  ..S X=$$SETSTR^VALM1($J(IBDVAL,3),X,66,3) D TMP
  1.  ..S X="",X=$$SETSTR^VALM1($$LOWER^VALM1("   BLOCK WIDTH: "),X,1,16)
  1.  ..S IBDVAL=$S(IBDF("WDTH"):IBDF("WDTH"),1:"")
  1.  ..S X=$$SETSTR^VALM1($J(IBDVAL,3),X,17,3)
  1.  ..S X=$$SETSTR^VALM1($$LOWER^VALM1("   BLOCK HEIGHT: "),X,49,17)
  1.  ..S IBDVAL=$S(IBDF("HT"):IBDF("HT"),1:"")
  1.  ..S X=$$SETSTR^VALM1($J(IBDVAL,3),X,66,3) D TMP
  1.  Q
  1. TMP ; -- Set up Array
  1.  S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
  1.  S ^TMP("FORMOBJ",$J,IBDCNT,0)=X,^TMP("FORMOBJ",$J,"IDX",VALMCNT,IBDCNT1)=""
  1.  S ^TMP("FORMIDX",$J,IBDCNT)=VALMCNT_"^"_IBDFIFN_"^"_IBDF("BLK")
  1.  Q
  1.  ;
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1.  ;
  1. EXIT ; -- exit code
  1.  K IBDCAT,IBDNME,IBDTYPE,VALMCNT,IBDCNT,IBDCNT1,IBDNAME,IBDNUM,IBDNME,IBDFIFN,IBDVAL,IBDNODE,IBFASTXT,IBDF,IBBLOCK,IBDFNODE,IBDFSNOD,IBDFOBJ,IBDOBJ1,IBQUIT,IBDFFLAG,IBDOBJ
  1.  K ^TMP("FORM-OBJ",$J),^TMP("FORMIDX",$J),^TMP("FORMOBJ",$J)
  1.  Q
  1.  ;
  1. NUL ; -- NULL MESSAGE
  1.  S ^TMP("FORMOBJ",$J,1,0)=" ",^TMP("FORMOBJ",$J,2,0)="There are no Components listed for this form.",^TMP("FORMIDX",$J,1)=1,^TMP("FORMIDX",$J,2)=2
  1.  Q
  1.  ;
  1. HDR ; -- print patient header
  1.  ;Q:'$D(IBDFIFN)
  1.  S X="     Form Name: "_$E($P($G(^IBE(357,+IBDFIFN,0)),"^"),1,25)
  1.  S IBDVAL="FORM ID #: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",13):$P(^IBE(357,+IBDFIFN,0),"^",13),1:"")
  1.  S VALMHDR(1)=$$SETSTR^VALM1(IBDVAL,X,55,25)
  1.  S X="        Status: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",5):"Compiled",1:"Uncompiled")
  1.  S IBDVAL="  Toolkit: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",7):"Yes",1:"No")
  1.  S VALMHDR(2)=$$SETSTR^VALM1(IBDVAL,X,55,25)
  1.  S X="     Scannable: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",12):"Yes",1:"No")
  1.  S IBDVAL="  Use ICR: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",6):"Yes",1:"No")
  1.  S VALMHDR(3)=$$SETSTR^VALM1(IBDVAL,X,55,25)
  1.  S X=+$P($G(^IBE(357,+IBDFIFN,0)),"^",2)
  1.  S X="Simplex/Duplex: "_$S(X]""&(X=0):"Simplex",X]""&(X=1):"Duplex Long-Edge",X]""&(X=2):"Duplex Short-Edge",1:"")
  1.  S IBDVAL="  # Pages: "_$S(+$P($G(^IBE(357,+IBDFIFN,0)),"^",11):+$P($G(^IBE(357,+IBDFIFN,0)),"^",11),1:"0")
  1.  S VALMHDR(4)=$$SETSTR^VALM1(IBDVAL,X,55,25)
  1.  Q
  1.  ;
  1. END I $D(ZTQUEUED) S ZTREQ="@" Q
  1.  K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF,IBDPAG,ZTSK,IBDFIFN
  1.  K ^TMP("FORMIDX",$J),^TMP("FORM-OBJ",$J),^TMP("FORMOBJ",$J)
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. EXP ;  -- Expand Action
  1.  D FULL^VALM1
  1.  N VALMI,VALMAT,VALMY
  1.  D EN^VALM2(XQORNOD(0),"O") S VALMI=0
  1.  F  S VALMI=$O(VALMY(VALMI)) Q:'VALMI  D
  1.  .S VALMAT=$G(IBBLOCK(VALMI))
  1.  .W !
  1.  .I DUZ(0)="@" W !,"Entry No. ",+$P(VALMAT,"^",11)
  1.  .S DA=+$P(VALMAT,U,11),DIC="^IBE(357.1,",DR="0" D EN^DIQ,PAUSE^VALM1
  1.  .K DA,DIC,DR
  1.  S VALMBCK="R"
  1.  Q