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

IBDFDE9.m

Go to the documentation of this file.
  1. IBDFDE9 ;ALB/AAS - AICS Manual Data Entry, Report of inputs by form ; 31-MAY-96
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. ;
  1. % N I,J,X,Y,DIR,DIRUT,DTOUT,DUOUT,IBDF,IBDFMIEN,IBDPAG,IBDPDT,IBDOJB,IBQUIT,QLFR,RULE
  1. ;
  1. I '$D(DT) D DT^DICRW
  1. D HOME^%ZIS
  1. W !!,"Display Form Components for Data Entry",!!
  1. ;
  1. STRT ; -- 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) G END
  1. S IBDFMIEN=+Y
  1. ;
  1. ; -- Ask Device
  1. S %ZIS="MQ" D ^%ZIS I POP G STRTQ
  1. ; -- queue if selected
  1. I $D(IO("Q")) S ZTSAVE("IBD*")="",ZTRTN="DQ^IBDFDE9",ZTDESC="IBD - Print form components" D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled") D HOME^%ZIS W !! G STRT
  1. U IO
  1. S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. D DQ
  1. ;
  1. STRTQ G:$G(IBQUIT) END D PAUSE^IBDFDE
  1. G STRT
  1. ;
  1. DQ ; -- entry point to list contents of one form,
  1. ; Input IBDFMIEN := pointer to Encounter Form (357)
  1. ;
  1. S IBQUIT=0
  1. S IBDPAG=0
  1. S IBDPDT=$$FMTE^XLFDT($$NOW^XLFDT)
  1. D HDR
  1. ;
  1. I '$D(^TMP("IBD-OBJ",$J,IBDFMIEN,0)) D FRMLSTI^IBDFRPC("^TMP(""IBD-OBJ"",$J,IBDFMIEN)",IBDFMIEN,"",1)
  1. D LISTOB
  1. Q
  1. ;
  1. LISTOB ; -- list items available for input on a form
  1. W !,"CHECKOUT INTERVIEW",?27,"",?45,"As Required",!
  1. S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I=""!(IBQUIT) D
  1. .I $E(IOST,1,2)="C-",$Y>(IOSL-5) D HDR Q:IBQUIT
  1. .S IBDOBJ=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I))
  1. .Q:'$P(IBDOBJ,"^",8)
  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. .Q:IBDF("IEN")<1!(IBDF("PI")<1)
  1. .S RTN=$G(^IBE(357.6,IBDF("PI"),18)) Q:RTN=""
  1. .S Y=$S($P(IBDOBJ,"^",7)="":$P(IBDOBJ,"^"),1:$P(IBDOBJ,"^",7))
  1. .I Y["INPUT " S Y=$P(Y,"INPUT ",2)
  1. .W !,$E(Y,1,25),?27,$S(IBDF("TYPE")="HP":"Hand Print",IBDF("TYPE")="LIST":"Selection List",1:"Multiple Choice")
  1. .;
  1. .S IBDF("DFN")=$O(^DPT(0)),IBDF("CLINIC")=$O(^SC(0)),IBDF("RULE-ONLY")=1
  1. .S RULE(0)=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN")))
  1. .I RULE(0)="" D OBJLST^IBDFRPC1(.RULE,.IBDF)
  1. .D RULES(.RULE)
  1. .W !
  1. W !
  1. Q
  1. ;
  1. HDR ; -- print patient header
  1. S IBDPAG=IBDPAG+1
  1. I $E(IOST,1,2)="C-",$Y>1,IBDPAG>1 D PAUSE^IBDFDE Q:IBQUIT
  1. I $E(IOST,1,2)="C-"!(IBDPAG>1) W @IOF
  1. W !,"Form Components Available for Data Entry",?IOM-32,IBDPDT," PAGE: ",IBDPAG
  1. W !,"COMPONENT",?27,"TYPE",?45,"RULE",?60,"QUALIFIER"
  1. W !,$TR($J(" ",IOM)," ","-")
  1. W !," Form Name: ",$E($P($G(^IBE(357,+IBDFMIEN,0)),"^"),1,25)
  1. W !," Form Status: ",$S(+$P($G(^IBE(357,+IBDFMIEN,0)),"^",5):"Compiled",1:"Uncompiled"),!
  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
  1. K ^TMP("IBD-OBJ",$J)
  1. D ^%ZISC
  1. Q
  1. ;
  1. RULES(RULE) ; -- look at zero node, find qualifiers and selection rule
  1. N I,QLFR,DQR
  1. S RULE=$P(RULE(0),"^",3),QLFR=""
  1. I $P(RULE(0),"^",4) W ?45,"Data Entry Not allowed",!,?45,"Marking areas not Bubbles" Q
  1. F I=1:1 S ROW=$P(RULE,"::",I) Q:ROW="" S QLFR(I)=$P(ROW,";;",1),RULE(I)=$P(ROW,";;",2) D
  1. .W:I>1 !
  1. .;
  1. .I IBDF("VITAL")="" W ?45,$P("Any Number^Exactly One^At Most One^At Least One","^",(RULE(I)+1))
  1. .E W ?45,"Optional"
  1. .;
  1. .I IBDF("VITAL")'="",QLFR(I)[":" S QLFR(I)=$P(QLFR(I),":") ;strip ":"
  1. .W ?60,$E(QLFR(I),1,20)
  1. .I QLFR(I)="",$P($G(^IBE(357.6,+$G(IBDF("PI")),0)),"^",19) W ?60,$G(IOINHI),"Required/Missing",$G(IOINORM)
  1. .I QLFR(I)="PRIMARY" D
  1. ..;S RULE(I)=$S(RULE(I)=3:1,RULE(I)=0:2,1:RULE(I))
  1. S RULE=I-1
  1. Q