IBDF6A ;ALB/CJM - ENCOUNTER FORM - (new forms, deleting forms, adding to setup) ;JAN 16,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
DELFORM ;
N CLINIC,FORM,BLOCK,NOCANDO,SETUP,ARY
S NOCANDO=0,ARY="^TMP(""IBDF"",$J,""TEMPORARY CLINIC LIST"")"
K @ARY
D FULL^VALM1
S VALMBCK="R"
K DIC S DIC("S")="I '$P(^(0),U,7)",DIC=357,DIC(0)="AEQ",DIC("A")="Select FORM to delete: "
D ^DIC K DIC S FORM=+Y Q:(FORM<0)
D CLINICS^IBDFU4(FORM,ARY)
I $G(@ARY@(0)) D
.W !,"Cannot be deleted, the form is in use!"
.D LIST^IBDFU4(ARY,IOSL)
I '$G(@ARY@(0)) D DELETE^IBDFU2C(FORM,357,1)
K @ARY
Q
;
NEWFORM ;
N NAME,FORM,FLD,BLOCK,IBDELETE,IBTXTSZ,IBSCAN,IBDVR
S (IBTXTSZ,IBSCAN)=0
S VALMBCK="R"
S NAME=$$NEWNAME^IBDFU2C Q:NAME=""
D FULL^VALM1
K DIC,DD,DO,DINUM S DIC="^IBE(357,",DIC(0)="",X=NAME
D FILE^DICN K DIC,DIE,DA
S FORM=+Y
I FORM<0 D
.W !,"Unable to create a new form!" D PAUSE^IBDFU5
E D
.K DIE,DR,DA S DIE="^IBE(357,",DR="[IBDF EDIT NEW FORM]",DA=FORM,DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.I IBDELETE S DIK="^IBE(357,",DA=FORM D ^DIK K DIK,DA Q
.D:'IBTKFORM ADDSETUP(FORM,IBCLINIC,1)
.;the new form should be empty - make sure
.S BLOCK="" F S BLOCK=$O(^IBE(357.1,"C",FORM,BLOCK)) Q:'BLOCK D
..I $P($G(^IBE(357.1,BLOCK,0)),"^",2)'=FORM D
...K DA S DIK="^IBE(357.1,",DA=BLOCK D IX^DIK K DIK,DA
..E D DLTBLK^IBDFU3(BLOCK,FORM,357.1)
.X IBAPI("INDEX")
Q
COPYFORM ;
N NAME,OLDFORM,NEWFORM,IBDELETE,IBOLD,IBSCAN
D FULL^VALM1
S VALMBCK="R"
S OLDFORM=$$SLCTFORM^IBDFU4("") Q:'OLDFORM
S NAME=$$NEWNAME^IBDFU2C Q:NAME=""
S NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,357,NAME,0)
Q:'NEWFORM
;
;edit the form
S IBOLD=$S($P($G(^IBE(357,NEWFORM,0)),"^",16):0,1:1)
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
;delete the new form if the user didn't complete the edit
I IBDELETE D DELETE^IBDFU2C(NEWFORM,357) Q
;
D:'IBTKFORM ADDSETUP(NEWFORM,IBCLINIC,1)
X IBAPI("INDEX")
Q
SETUP ;
N FORM
D FULL^VALM1
S VALMBCK="R"
K DIC S DIC("S")="I '$P(^(0),U,7)",DIC=357,DIC(0)="AEQ",DIC("A")="Select FORM for Clinic Setup: "
D ^DIC K DIC Q:($D(DTOUT)!$D(DUOUT)) S FORM=+Y Q:FORM<0
D ADDSETUP(FORM,IBCLINIC,0)
X IBAPI("INDEX")
Q
ADDSETUP(FORM,IBCLINIC,NEW) ;
;NEW=1 if the form was just created, 0 otherwise
N FLD,NODE,SETUP
S NEW=+$G(NEW)
K DA S DA=$O(^SD(409.95,"B",+$G(IBCLINIC),"")) I 'DA D
.K DIC,DO,DD,DINUM S DIC="^SD(409.95,",DIC(0)="",X=IBCLINIC
.D FILE^DICN K DIC
.S DA=$S(+Y<1:0,1:+Y)
Q:'DA
S SETUP=DA,NODE=$G(^SD(409.95,SETUP,0))
W !,"How should the clinic use the form?"
K DIR
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;"
S:NEW DIR(0)=DIR(0)_"7:WILL NOT BE USED BY CLINIC;"
D ^DIR K DIR
I (Y=-1)!(Y=7)!$D(DIRUT) Q
S:Y'=2 FLD=$S(Y=1:.02,Y=3:.04,Y=4:.03,Y=5:.05,Y=6:.07,1:0)
S:Y=2 FLD=$S('$P(NODE,"^",6):.06,'$P(NODE,"^",8):.08,1:.09)
Q:'FLD
I $P($G(^SD(409.95,DA,0)),"^",(100*FLD)) Q:'$$OVERLAY
K DIE,DR S DIE=409.95
S DR=FLD_"////"_FORM D ^DIE K DIE,DR,DA
Q
OVERLAY() ;asks the user if the he wants to overlay the form already used for the clinic setup
W !,"But you already have a form for that use!"
K DIR S DIR(0)="Y",DIR("A")="Do you want to replace it"
D ^DIR K DIR
Q:$D(DIRUT) 0
Q Y
IBDF6A ;ALB/CJM - ENCOUNTER FORM - (new forms, deleting forms, adding to setup) ;JAN 16,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
DELFORM ;
+1 NEW CLINIC,FORM,BLOCK,NOCANDO,SETUP,ARY
+2 SET NOCANDO=0
SET ARY="^TMP(""IBDF"",$J,""TEMPORARY CLINIC LIST"")"
+3 KILL @ARY
+4 DO FULL^VALM1
+5 SET VALMBCK="R"
+6 KILL DIC
SET DIC("S")="I '$P(^(0),U,7)"
SET DIC=357
SET DIC(0)="AEQ"
SET DIC("A")="Select FORM to delete: "
+7 DO ^DIC
KILL DIC
SET FORM=+Y
IF (FORM<0)
QUIT
+8 DO CLINICS^IBDFU4(FORM,ARY)
+9 IF $GET(@ARY@(0))
Begin DoDot:1
+10 WRITE !,"Cannot be deleted, the form is in use!"
+11 DO LIST^IBDFU4(ARY,IOSL)
End DoDot:1
+12 IF '$GET(@ARY@(0))
DO DELETE^IBDFU2C(FORM,357,1)
+13 KILL @ARY
+14 QUIT
+15 ;
NEWFORM ;
+1 NEW NAME,FORM,FLD,BLOCK,IBDELETE,IBTXTSZ,IBSCAN,IBDVR
+2 SET (IBTXTSZ,IBSCAN)=0
+3 SET VALMBCK="R"
+4 SET NAME=$$NEWNAME^IBDFU2C
IF NAME=""
QUIT
+5 DO FULL^VALM1
+6 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357,"
SET DIC(0)=""
SET X=NAME
+7 DO FILE^DICN
KILL DIC,DIE,DA
+8 SET FORM=+Y
+9 IF FORM<0
Begin DoDot:1
+10 WRITE !,"Unable to create a new form!"
DO PAUSE^IBDFU5
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 KILL DIE,DR,DA
SET DIE="^IBE(357,"
SET DR="[IBDF EDIT NEW FORM]"
SET DA=FORM
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+13 IF IBDELETE
SET DIK="^IBE(357,"
SET DA=FORM
DO ^DIK
KILL DIK,DA
QUIT
+14 IF 'IBTKFORM
DO ADDSETUP(FORM,IBCLINIC,1)
+15 ;the new form should be empty - make sure
+16 SET BLOCK=""
FOR
SET BLOCK=$ORDER(^IBE(357.1,"C",FORM,BLOCK))
IF 'BLOCK
QUIT
Begin DoDot:2
+17 IF $PIECE($GET(^IBE(357.1,BLOCK,0)),"^",2)'=FORM
Begin DoDot:3
+18 KILL DA
SET DIK="^IBE(357.1,"
SET DA=BLOCK
DO IX^DIK
KILL DIK,DA
End DoDot:3
+19 IF '$TEST
DO DLTBLK^IBDFU3(BLOCK,FORM,357.1)
End DoDot:2
+20 XECUTE IBAPI("INDEX")
End DoDot:1
+21 QUIT
COPYFORM ;
+1 NEW NAME,OLDFORM,NEWFORM,IBDELETE,IBOLD,IBSCAN
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 SET OLDFORM=$$SLCTFORM^IBDFU4("")
IF 'OLDFORM
QUIT
+5 SET NAME=$$NEWNAME^IBDFU2C
IF NAME=""
QUIT
+6 SET NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,357,NAME,0)
+7 IF 'NEWFORM
QUIT
+8 ;
+9 ;edit the form
+10 SET IBOLD=$SELECT($PIECE($GET(^IBE(357,NEWFORM,0)),"^",16):0,1:1)
+11 KILL DIE,DR,DA
SET DIE="^IBE(357,"
SET DR="[IBDF EDIT OLD OR COPIED FORM]"
SET DA=NEWFORM
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+12 ;delete the new form if the user didn't complete the edit
+13 IF IBDELETE
DO DELETE^IBDFU2C(NEWFORM,357)
QUIT
+14 ;
+15 IF 'IBTKFORM
DO ADDSETUP(NEWFORM,IBCLINIC,1)
+16 XECUTE IBAPI("INDEX")
+17 QUIT
SETUP ;
+1 NEW FORM
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 KILL DIC
SET DIC("S")="I '$P(^(0),U,7)"
SET DIC=357
SET DIC(0)="AEQ"
SET DIC("A")="Select FORM for Clinic Setup: "
+5 DO ^DIC
KILL DIC
IF ($DATA(DTOUT)!$DATA(DUOUT))
QUIT
SET FORM=+Y
IF FORM<0
QUIT
+6 DO ADDSETUP(FORM,IBCLINIC,0)
+7 XECUTE IBAPI("INDEX")
+8 QUIT
ADDSETUP(FORM,IBCLINIC,NEW) ;
+1 ;NEW=1 if the form was just created, 0 otherwise
+2 NEW FLD,NODE,SETUP
+3 SET NEW=+$GET(NEW)
+4 KILL DA
SET DA=$ORDER(^SD(409.95,"B",+$GET(IBCLINIC),""))
IF 'DA
Begin DoDot:1
+5 KILL DIC,DO,DD,DINUM
SET DIC="^SD(409.95,"
SET DIC(0)=""
SET X=IBCLINIC
+6 DO FILE^DICN
KILL DIC
+7 SET DA=$SELECT(+Y<1:0,1:+Y)
End DoDot:1
+8 IF 'DA
QUIT
+9 SET SETUP=DA
SET NODE=$GET(^SD(409.95,SETUP,0))
+10 WRITE !,"How should the clinic use the form?"
+11 KILL DIR
+12 SET 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;"
+13 IF NEW
SET DIR(0)=DIR(0)_"7:WILL NOT BE USED BY CLINIC;"
+14 DO ^DIR
KILL DIR
+15 IF (Y=-1)!(Y=7)!$DATA(DIRUT)
QUIT
+16 IF Y'=2
SET FLD=$SELECT(Y=1:.02,Y=3:.04,Y=4:.03,Y=5:.05,Y=6:.07,1:0)
+17 IF Y=2
SET FLD=$SELECT('$PIECE(NODE,"^",6):.06,'$PIECE(NODE,"^",8):.08,1:.09)
+18 IF 'FLD
QUIT
+19 IF $PIECE($GET(^SD(409.95,DA,0)),"^",(100*FLD))
IF '$$OVERLAY
QUIT
+20 KILL DIE,DR
SET DIE=409.95
+21 SET DR=FLD_"////"_FORM
DO ^DIE
KILL DIE,DR,DA
+22 QUIT
OVERLAY() ;asks the user if the he wants to overlay the form already used for the clinic setup
+1 WRITE !,"But you already have a form for that use!"
+2 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to replace it"
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT 0
+5 QUIT Y
