IBDF6A ;ALB/CJM - ENCOUNTER FORM - (new forms, deleting forms, adding to setup) ;01/16/93
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
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,IBDFORM,IBDLST,IBDX,IBDCS,IBDY
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")
;Now check if new form contains any selection lists that specify ICD-9 or ICD-10
;if so, update history field at #357 .19 or .2 plus field .21
S IBDFORM=0 F S IBDFORM=$O(^IBE(357.1,"C",NEWFORM,IBDFORM)) Q:IBDFORM="" D
.S IBDLST=0 F S IBDLST=$O(^IBE(357.2,"C",IBDFORM,IBDLST)) Q:IBDLST="" S IBDX=$P(^IBE(357.2,IBDLST,0),U,11) D:IBDX?1.N
..S IBDCS=$P(^IBE(357.6,IBDX,0),U,22) D:IBDCS=1!(IBDCS=30) ;Coding System 1=ICD-9 30=ICD-10
...I '$O(^IBE(357.3,"C",IBDLST,"")) Q ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
...S IBDY=$$CSUPD357^IBDUTICD(NEWFORM,IBDCS,"",$$NOW^XLFDT(),DUZ)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF6A 4174 printed Dec 13, 2024@02:51:35 Page 2
IBDF6A ;ALB/CJM - ENCOUNTER FORM - (new forms, deleting forms, adding to setup) ;01/16/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
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,IBDFORM,IBDLST,IBDX,IBDCS,IBDY
+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 ;Now check if new form contains any selection lists that specify ICD-9 or ICD-10
+18 ;if so, update history field at #357 .19 or .2 plus field .21
+19 SET IBDFORM=0
FOR
SET IBDFORM=$ORDER(^IBE(357.1,"C",NEWFORM,IBDFORM))
if IBDFORM=""
QUIT
Begin DoDot:1
+20 SET IBDLST=0
FOR
SET IBDLST=$ORDER(^IBE(357.2,"C",IBDFORM,IBDLST))
if IBDLST=""
QUIT
SET IBDX=$PIECE(^IBE(357.2,IBDLST,0),U,11)
if IBDX?1.N
Begin DoDot:2
+21 ;Coding System 1=ICD-9 30=ICD-10
SET IBDCS=$PIECE(^IBE(357.6,IBDX,0),U,22)
if IBDCS=1!(IBDCS=30)
Begin DoDot:3
+22 ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
IF '$ORDER(^IBE(357.3,"C",IBDLST,""))
QUIT
+23 SET IBDY=$$CSUPD357^IBDUTICD(NEWFORM,IBDCS,"",$$NOW^XLFDT(),DUZ)
End DoDot:3
End DoDot:2
End DoDot:1
+24 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
