source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF6A.m@ 1501

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

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1IBDF6A ;ALB/CJM - ENCOUNTER FORM - (new forms, deleting forms, adding to setup) ;JAN 16,1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4DELFORM ;
5 N CLINIC,FORM,BLOCK,NOCANDO,SETUP,ARY
6 S NOCANDO=0,ARY="^TMP(""IBDF"",$J,""TEMPORARY CLINIC LIST"")"
7 K @ARY
8 D FULL^VALM1
9 S VALMBCK="R"
10 K DIC S DIC("S")="I '$P(^(0),U,7)",DIC=357,DIC(0)="AEQ",DIC("A")="Select FORM to delete: "
11 D ^DIC K DIC S FORM=+Y Q:(FORM<0)
12 D CLINICS^IBDFU4(FORM,ARY)
13 I $G(@ARY@(0)) D
14 .W !,"Cannot be deleted, the form is in use!"
15 .D LIST^IBDFU4(ARY,IOSL)
16 I '$G(@ARY@(0)) D DELETE^IBDFU2C(FORM,357,1)
17 K @ARY
18 Q
19 ;
20NEWFORM ;
21 N NAME,FORM,FLD,BLOCK,IBDELETE,IBTXTSZ,IBSCAN,IBDVR
22 S (IBTXTSZ,IBSCAN)=0
23 S VALMBCK="R"
24 S NAME=$$NEWNAME^IBDFU2C Q:NAME=""
25 D FULL^VALM1
26 K DIC,DD,DO,DINUM S DIC="^IBE(357,",DIC(0)="",X=NAME
27 D FILE^DICN K DIC,DIE,DA
28 S FORM=+Y
29 I FORM<0 D
30 .W !,"Unable to create a new form!" D PAUSE^IBDFU5
31 E D
32 .K DIE,DR,DA S DIE="^IBE(357,",DR="[IBDF EDIT NEW FORM]",DA=FORM,DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
33 .I IBDELETE S DIK="^IBE(357,",DA=FORM D ^DIK K DIK,DA Q
34 .D:'IBTKFORM ADDSETUP(FORM,IBCLINIC,1)
35 .;the new form should be empty - make sure
36 .S BLOCK="" F S BLOCK=$O(^IBE(357.1,"C",FORM,BLOCK)) Q:'BLOCK D
37 ..I $P($G(^IBE(357.1,BLOCK,0)),"^",2)'=FORM D
38 ...K DA S DIK="^IBE(357.1,",DA=BLOCK D IX^DIK K DIK,DA
39 ..E D DLTBLK^IBDFU3(BLOCK,FORM,357.1)
40 .X IBAPI("INDEX")
41 Q
42COPYFORM ;
43 N NAME,OLDFORM,NEWFORM,IBDELETE,IBOLD,IBSCAN
44 D FULL^VALM1
45 S VALMBCK="R"
46 S OLDFORM=$$SLCTFORM^IBDFU4("") Q:'OLDFORM
47 S NAME=$$NEWNAME^IBDFU2C Q:NAME=""
48 S NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,357,NAME,0)
49 Q:'NEWFORM
50 ;
51 ;edit the form
52 S IBOLD=$S($P($G(^IBE(357,NEWFORM,0)),"^",16):0,1:1)
53 K DIE,DR,DA S DIE="^IBE(357,",DR="[IBDF EDIT OLD OR COPIED FORM]",DA=NEWFORM,DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
54 ;delete the new form if the user didn't complete the edit
55 I IBDELETE D DELETE^IBDFU2C(NEWFORM,357) Q
56 ;
57 D:'IBTKFORM ADDSETUP(NEWFORM,IBCLINIC,1)
58 X IBAPI("INDEX")
59 Q
60SETUP ;
61 N FORM
62 D FULL^VALM1
63 S VALMBCK="R"
64 K DIC S DIC("S")="I '$P(^(0),U,7)",DIC=357,DIC(0)="AEQ",DIC("A")="Select FORM for Clinic Setup: "
65 D ^DIC K DIC Q:($D(DTOUT)!$D(DUOUT)) S FORM=+Y Q:FORM<0
66 D ADDSETUP(FORM,IBCLINIC,0)
67 X IBAPI("INDEX")
68 Q
69ADDSETUP(FORM,IBCLINIC,NEW) ;
70 ;NEW=1 if the form was just created, 0 otherwise
71 N FLD,NODE,SETUP
72 S NEW=+$G(NEW)
73 K DA S DA=$O(^SD(409.95,"B",+$G(IBCLINIC),"")) I 'DA D
74 .K DIC,DO,DD,DINUM S DIC="^SD(409.95,",DIC(0)="",X=IBCLINIC
75 .D FILE^DICN K DIC
76 .S DA=$S(+Y<1:0,1:+Y)
77 Q:'DA
78 S SETUP=DA,NODE=$G(^SD(409.95,SETUP,0))
79 W !,"How should the clinic use the form?"
80 K DIR
81 S DIR(0)="SO^1:BASIC FORM;2:SUPPLEMENTAL FORM FOR ALL PATIENTS;3:SUPPLEMENTAL FORM FOR NEW PATIENTS;4:SUPPLEMENTAL FORM FOR ESTABLISHED PATIENTS;5:FORM TO PRINT WITHOUT PATIENT DATA;6:RESERVED FOR FUTURE USE;"
82 S:NEW DIR(0)=DIR(0)_"7:WILL NOT BE USED BY CLINIC;"
83 D ^DIR K DIR
84 I (Y=-1)!(Y=7)!$D(DIRUT) Q
85 S:Y'=2 FLD=$S(Y=1:.02,Y=3:.04,Y=4:.03,Y=5:.05,Y=6:.07,1:0)
86 S:Y=2 FLD=$S('$P(NODE,"^",6):.06,'$P(NODE,"^",8):.08,1:.09)
87 Q:'FLD
88 I $P($G(^SD(409.95,DA,0)),"^",(100*FLD)) Q:'$$OVERLAY
89 K DIE,DR S DIE=409.95
90 S DR=FLD_"////"_FORM D ^DIE K DIE,DR,DA
91 Q
92OVERLAY() ;asks the user if the he wants to overlay the form already used for the clinic setup
93 W !,"But you already have a form for that use!"
94 K DIR S DIR(0)="Y",DIR("A")="Do you want to replace it"
95 D ^DIR K DIR
96 Q:$D(DIRUT) 0
97 Q Y
Note: See TracBrowser for help on using the repository browser.