source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE9.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1IBDFDE9 ;ALB/AAS - AICS Manual Data Entry, Report of inputs by form ; 31-MAY-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**51**;APR 24, 1997
3 ;
4 W !,?4,"** This option is OUT OF ORDER **" QUIT ;Code set Versioning
5 ;
6% N I,J,X,Y,DIR,DIRUT,DTOUT,DUOUT,IBDF,IBDFMIEN,IBDPAG,IBDPDT,IBDOJB,IBQUIT,QLFR,RULE
7 ;
8 I '$D(DT) D DT^DICRW
9 D HOME^%ZIS
10 W !!,"Display Form Components for Data Entry",!!
11 ;
12STRT ; -- ask for form id
13 D END
14 S DIR("?")="Enter the Encounter Form Name you want to review."
15 S DIR(0)="PO^357:AEQM",DIR("A")="Select Encounter Form" D ^DIR K DIR,DA,DR,DIC
16 I $D(DIRUT) G END
17 S IBDFMIEN=+Y
18 ;
19 ; -- Ask Device
20 S %ZIS="MQ" D ^%ZIS I POP G STRTQ
21 ; -- queue if selected
22 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
23 U IO
24 S X="IOINHI;IOINORM" D ENDR^%ZISS
25 D DQ
26 ;
27STRTQ G:$G(IBQUIT) END D PAUSE^IBDFDE
28 G STRT
29 ;
30DQ ; -- entry point to list contents of one form,
31 ; Input IBDFMIEN := pointer to Encounter Form (357)
32 ;
33 S IBQUIT=0
34 S IBDPAG=0
35 S IBDPDT=$$FMTE^XLFDT($$NOW^XLFDT)
36 D HDR
37 ;
38 I '$D(^TMP("IBD-OBJ",$J,IBDFMIEN,0)) D FRMLSTI^IBDFRPC("^TMP(""IBD-OBJ"",$J,IBDFMIEN)",IBDFMIEN,"",1)
39 D LISTOB
40 Q
41 ;
42LISTOB ; -- list items available for input on a form
43 W !,"CHECKOUT INTERVIEW",?27,"",?45,"As Required",!
44 S I=0 F S I=$O(^TMP("IBD-OBJ",$J,IBDFMIEN,I)) Q:I=""!(IBQUIT) D
45 .I $E(IOST,1,2)="C-",$Y>(IOSL-5) D HDR Q:IBQUIT
46 .S IBDOBJ=$G(^TMP("IBD-OBJ",$J,IBDFMIEN,I))
47 .Q:'$P(IBDOBJ,"^",8)
48 .S IBDF("PI")=+$P(IBDOBJ,"^",2),IBDF("TYPE")=$P(IBDOBJ,"^",5)
49 .S IBDF("IEN")=+$P(IBDOBJ,"^",6),IBDF("VITAL")=$P(IBDOBJ,"^",7)
50 .Q:IBDF("IEN")<1!(IBDF("PI")<1)
51 .S RTN=$G(^IBE(357.6,IBDF("PI"),18)) Q:RTN=""
52 .S Y=$S($P(IBDOBJ,"^",7)="":$P(IBDOBJ,"^"),1:$P(IBDOBJ,"^",7))
53 .I Y["INPUT " S Y=$P(Y,"INPUT ",2)
54 .W !,$E(Y,1,25),?27,$S(IBDF("TYPE")="HP":"Hand Print",IBDF("TYPE")="LIST":"Selection List",1:"Multiple Choice")
55 .;
56 .S IBDF("DFN")=$O(^DPT(0)),IBDF("CLINIC")=$O(^SC(0)),IBDF("RULE-ONLY")=1
57 .S RULE(0)=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN")))
58 .I RULE(0)="" D OBJLST^IBDFRPC1(.RULE,.IBDF)
59 .D RULES(.RULE)
60 .W !
61 W !
62 Q
63 ;
64HDR ; -- print patient header
65 S IBDPAG=IBDPAG+1
66 I $E(IOST,1,2)="C-",$Y>1,IBDPAG>1 D PAUSE^IBDFDE Q:IBQUIT
67 I $E(IOST,1,2)="C-"!(IBDPAG>1) W @IOF
68 W !,"Form Components Available for Data Entry",?IOM-32,IBDPDT," PAGE: ",IBDPAG
69 W !,"COMPONENT",?27,"TYPE",?45,"RULE",?60,"QUALIFIER"
70 W !,$TR($J(" ",IOM)," ","-")
71 W !," Form Name: ",$E($P($G(^IBE(357,+IBDFMIEN,0)),"^"),1,25)
72 W !," Form Status: ",$S(+$P($G(^IBE(357,+IBDFMIEN,0)),"^",5):"Compiled",1:"Uncompiled"),!
73 Q
74 ;
75END I $D(ZTQUEUED) S ZTREQ="@" Q
76 K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF,IBDPAG,ZTSK
77 K ^TMP("IBD-OBJ",$J)
78 D ^%ZISC
79 Q
80 ;
81RULES(RULE) ; -- look at zero node, find qualifiers and selection rule
82 N I,QLFR,DQR
83 S RULE=$P(RULE(0),"^",3),QLFR=""
84 I $P(RULE(0),"^",4) W ?45,"Data Entry Not allowed",!,?45,"Marking areas not Bubbles" Q
85 F I=1:1 S ROW=$P(RULE,"::",I) Q:ROW="" S QLFR(I)=$P(ROW,";;",1),RULE(I)=$P(ROW,";;",2) D
86 .W:I>1 !
87 .;
88 .I IBDF("VITAL")="" W ?45,$P("Any Number^Exactly One^At Most One^At Least One","^",(RULE(I)+1))
89 .E W ?45,"Optional"
90 .;
91 .I IBDF("VITAL")'="",QLFR(I)[":" S QLFR(I)=$P(QLFR(I),":") ;strip ":"
92 .W ?60,$E(QLFR(I),1,20)
93 .I QLFR(I)="",$P($G(^IBE(357.6,+$G(IBDF("PI")),0)),"^",19) W ?60,$G(IOINHI),"Required/Missing",$G(IOINORM)
94 .I QLFR(I)="PRIMARY" D
95 ..;S RULE(I)=$S(RULE(I)=3:1,RULE(I)=0:2,1:RULE(I))
96 S RULE=I-1
97 Q
Note: See TracBrowser for help on using the repository browser.