source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFC2B.m@ 1593

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

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1IBDFC2B ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning ;MAR 3, 1995
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4ADDOTHER ;add space to the list to write in other
5 N NODE
6 S NODE=$G(^IBE(357.2,IBLIST,0))
7 I NODE]"",$P(NODE,"^",16)="" S $P(NODE,"^",16)=1,$P(NODE,"^",17)=3,$P(NODE,"^",18)=2 S ^IBE(357.2,IBLIST,0)=NODE
8 Q
9 ;
10CKVALUES ;make sure the internal value to be passed matches the value displayed and is an active code
11 ;
12 Q:'IBLIST("INPUT_RTN")
13 N SUBCOL,I,SLCTN,IEN,TEXT,CODE,NODE
14 ;
15 ;find the subcolumn with the code
16 S SUBCOL=0 F I=1:1:8 I $G(IBLIST("SCPIECE",I))=1,$G(IBLIST("SCTYPE",I))=1 S SUBCOL=I
17 ;
18 ;check that the display of the code matches its id and that it's active
19 S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",IBLIST,SLCTN)) Q:'SLCTN D
20 .S NODE=$G(^IBE(357.3,SLCTN,0))
21 .;
22 .;check if place holder
23 .Q:$P(NODE,"^",2)
24 .;
25 .S CODE=$P(NODE,"^")
26 .Q:CODE=""
27 .;
28 .;check for inactive codes
29 .I '$$CKACTIVE(CODE,IBLIST("RTN")) D
30 ..S TEXT=$$DISPLAY(SLCTN)
31 ..D WARNING^IBDFC2("IN THE SELECTION LIST '"_IBLIST("NAME")_"' THE ENTRY="_TEXT_" IS AN INACTIVE CODE")
32 .;
33 .;check for displayed codes that don't match their id stored on piece 1
34 .Q:'SUBCOL
35 .S IEN=$O(^IBE(357.3,SLCTN,1,"B",SUBCOL,0))
36 .Q:'IEN
37 .S TEXT=$P($G(^IBE(357.3,SLCTN,1,IEN,0)),"^",2)
38 .Q:'$L(TEXT)
39 .I CODE'=TEXT D
40 ..; -- codes doesn't match text and autochange= yes
41 ..I $G(IBDASK("AUTOCHG")),$$CKACTIVE(TEXT,IBLIST("RTN")) D Q
42 ...; use fm to update data and x-refs S $P(^IBE(357.3,SLCTN,0),"^")=TEXT
43 ...S DIE=357.3,DR=".01////^S X=TEXT",DA=SLCTN D ^DIE K DIE,DA,DR
44 ...D WARNING^IBDFC2("In the Selection List '"_IBLIST("NAME")_"' the Code="_CODE_" was automatically update to match the text="_TEXT)
45 ...Q
46 ..D WARNING^IBDFC2("IN THE SELECTION LIST '"_IBLIST("NAME")_"' THE CODE="_TEXT_" IS DISPLAYED BUT THE CODE="_CODE_" WILL BE TRANSMITTED") Q
47 Q
48 ;
49CHKVISIT ;should the selection list use the new Package Interface for Type of Visit?
50 ;
51 I ($$UP^XLFSTR(IBLIST("NAME"))["VISIT")!($$UP^XLFSTR(IBBLK("NAME"))["VISIT"),IBLIST("RTN") I $P($G(^IBE(357.6,IBLIST("RTN"),0)),"^")["SELECT CPT PROCEDURE" D
52 .N SLCTN,CODE,PI,CHANGE
53 .S PI=$O(^IBE(357.6,"B","DG SELECT VISIT TYPE CPT PROCE",0))
54 .Q:'PI
55 .S CHANGE=1,SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",IBLIST,SLCTN)) Q:'SLCTN S CODE=$P($G(^IBE(357.3,SLCTN,0)),"^") I CODE I '$D(^IBE(357.69,CODE,0)) S CHANGE=0 Q
56 .;change the list to visit type
57 .I CHANGE D
58 ..N CNT,SC,NODE,SUB S (CNT,SC)=""
59 ..;change the package interface to type of visit
60 ..S $P(^IBE(357.2,IBLIST,0),"^",11)=PI
61 ..;set the selection rule to exactly one as long as there is only one marking subcolumn
62 ..F S SC=$O(^IBE(357.2,IBLIST,2,SC)) Q:'SC S NODE=$G(^IBE(357.2,IBLIST,2,SC,0)) I $P(NODE,"^",4)=2 S CNT=CNT+1,SUB=SC
63 ..I CNT=1,$P(NODE,"^",10)="" S $P(^IBE(357.2,IBLIST,2,SUB,0),"^",10)=1
64 .;
65 .I 'CHANGE,IBLIST("NAME")["VISIT",IBLIST("NAME")["TYPE" D WARNING^IBDFC2("THE BLOCK '"_IBBLK("NAME")_"' HAS A LIST FOR CPT PROCEDURES THAT PERHAPS SHOULD BE REPLACED WITH VISIT TYPE")
66 Q
67 ;
68CKACTIVE(X,PI) ;returns 1 if the X=an active code, 0 otherwise
69 Q:'PI 1
70 X $G(^IBE(357.6,PI,11))
71 Q $D(X)
72 ;
73DISPLAY(SLCTN) ;returns selection display
74 N SC,SCDA,VAL,RET,W,NODE
75 ;W - an array cotaining the widths of the subcolumns that contain text
76 S NODE=$G(^IBE(357.3,SLCTN,0))
77 S RET=" ",(VAL,SC)=""
78 F SC=1:1:8 S SCDA=$O(^IBE(357.3,SLCTN,1,"B",SC,"")) D
79 .I $G(IBLIST("SCTYPE",SC))=1 S W(SC)=IBLIST("SCW",SC)*(1+IBLIST("BTWN"))
80 .S:$G(W(SC)) VAL=$$PADRIGHT^IBDFU($S(SCDA:$P($G(^IBE(357.3,SLCTN,1,SCDA,0)),"^",2),1:""),W(SC))
81 .S:VAL'="" RET=RET_" "_VAL
82 .S VAL=""
83 Q RET
84 ;
85ASKOTH() ; Function
86 ; -- ask if want to add other hand print field automatically
87 ; Returns 1 if yes, 0 if no, or -1 if uparrow
88 ;
89 N X,Y,ANS,DIR
90 W !
91 S ANS=-1
92 S DIR("?")="Answer YES if you want to automatically add 1 hand print field to each selection list. If you answer NO nothing will be added."
93 S DIR("?",1)=" Hand print fields can be automatically added to your form"
94 S DIR("?",2)=" if you wish. If there isn't suffient room in the block"
95 S DIR("?",3)=" or on the form them adding the hand print field will cause"
96 S DIR("?",4)=" part of the list to disappear."
97 S DIR("?",5)=" "
98 S DIR(0)="Y",DIR("B")="NO"
99 S DIR("A")="Automatically Add 'Other' Hand Print Fields"
100 D ^DIR
101 I $D(DIRUT) G ASKOTHQ
102 S ANS=Y
103ASKOTHQ Q ANS
104 ;
105ASKAUTO() ; Function
106 ; -- ask if want to automatically update codes
107 ; Returns 1 if yes, 0 if no, or -1 if uparrow
108 ;
109 N X,Y,ANS,DIR
110 W !
111 S ANS=-1
112 S DIR("?")="Answer YES if you want codes in the selection lists that will be transmitted to PCE to automatically be updated to match the displayed codes. If you answer No, warnings will be generated but the codes will not be updated."
113 S DIR(0)="Y",DIR("B")="NO"
114 S DIR("A")="Automatically update codes to be transmitted"
115 D ^DIR
116 I $D(DIRUT) G ASKAUTQ
117 S ANS=Y
118ASKAUTQ Q ANS
Note: See TracBrowser for help on using the repository browser.