Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDF6A

IBDF6A.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. DELFORM ;
  1. N CLINIC,FORM,BLOCK,NOCANDO,SETUP,ARY
  1. S NOCANDO=0,ARY="^TMP(""IBDF"",$J,""TEMPORARY CLINIC LIST"")"
  1. K @ARY
  1. D FULL^VALM1
  1. S VALMBCK="R"
  1. K DIC S DIC("S")="I '$P(^(0),U,7)",DIC=357,DIC(0)="AEQ",DIC("A")="Select FORM to delete: "
  1. D ^DIC K DIC S FORM=+Y Q:(FORM<0)
  1. D CLINICS^IBDFU4(FORM,ARY)
  1. I $G(@ARY@(0)) D
  1. .W !,"Cannot be deleted, the form is in use!"
  1. .D LIST^IBDFU4(ARY,IOSL)
  1. I '$G(@ARY@(0)) D DELETE^IBDFU2C(FORM,357,1)
  1. K @ARY
  1. Q
  1. ;
  1. NEWFORM ;
  1. N NAME,FORM,FLD,BLOCK,IBDELETE,IBTXTSZ,IBSCAN,IBDVR
  1. S (IBTXTSZ,IBSCAN)=0
  1. S VALMBCK="R"
  1. S NAME=$$NEWNAME^IBDFU2C Q:NAME=""
  1. D FULL^VALM1
  1. K DIC,DD,DO,DINUM S DIC="^IBE(357,",DIC(0)="",X=NAME
  1. D FILE^DICN K DIC,DIE,DA
  1. S FORM=+Y
  1. I FORM<0 D
  1. .W !,"Unable to create a new form!" D PAUSE^IBDFU5
  1. E D
  1. .K DIE,DR,DA S DIE="^IBE(357,",DR="[IBDF EDIT NEW FORM]",DA=FORM,DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
  1. .I IBDELETE S DIK="^IBE(357,",DA=FORM D ^DIK K DIK,DA Q
  1. .D:'IBTKFORM ADDSETUP(FORM,IBCLINIC,1)
  1. .;the new form should be empty - make sure
  1. .S BLOCK="" F S BLOCK=$O(^IBE(357.1,"C",FORM,BLOCK)) Q:'BLOCK D
  1. ..I $P($G(^IBE(357.1,BLOCK,0)),"^",2)'=FORM D
  1. ...K DA S DIK="^IBE(357.1,",DA=BLOCK D IX^DIK K DIK,DA
  1. ..E D DLTBLK^IBDFU3(BLOCK,FORM,357.1)
  1. .X IBAPI("INDEX")
  1. Q
  1. COPYFORM ;
  1. N NAME,OLDFORM,NEWFORM,IBDELETE,IBOLD,IBSCAN,IBDFORM,IBDLST,IBDX,IBDCS,IBDY
  1. D FULL^VALM1
  1. S VALMBCK="R"
  1. S OLDFORM=$$SLCTFORM^IBDFU4("") Q:'OLDFORM
  1. S NAME=$$NEWNAME^IBDFU2C Q:NAME=""
  1. S NEWFORM=$$COPYFORM^IBDFU2C(OLDFORM,357,357,NAME,0)
  1. Q:'NEWFORM
  1. ;
  1. ;edit the form
  1. S IBOLD=$S($P($G(^IBE(357,NEWFORM,0)),"^",16):0,1: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
  1. ;delete the new form if the user didn't complete the edit
  1. I IBDELETE D DELETE^IBDFU2C(NEWFORM,357) Q
  1. ;
  1. D:'IBTKFORM ADDSETUP(NEWFORM,IBCLINIC,1)
  1. X IBAPI("INDEX")
  1. ;Now check if new form contains any selection lists that specify ICD-9 or ICD-10
  1. ;if so, update history field at #357 .19 or .2 plus field .21
  1. S IBDFORM=0 F S IBDFORM=$O(^IBE(357.1,"C",NEWFORM,IBDFORM)) Q:IBDFORM="" D
  1. .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
  1. ..S IBDCS=$P(^IBE(357.6,IBDX,0),U,22) D:IBDCS=1!(IBDCS=30) ;Coding System 1=ICD-9 30=ICD-10
  1. ...I '$O(^IBE(357.3,"C",IBDLST,"")) Q ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
  1. ...S IBDY=$$CSUPD357^IBDUTICD(NEWFORM,IBDCS,"",$$NOW^XLFDT(),DUZ)
  1. Q
  1. SETUP ;
  1. N FORM
  1. D FULL^VALM1
  1. S VALMBCK="R"
  1. K DIC S DIC("S")="I '$P(^(0),U,7)",DIC=357,DIC(0)="AEQ",DIC("A")="Select FORM for Clinic Setup: "
  1. D ^DIC K DIC Q:($D(DTOUT)!$D(DUOUT)) S FORM=+Y Q:FORM<0
  1. D ADDSETUP(FORM,IBCLINIC,0)
  1. X IBAPI("INDEX")
  1. Q
  1. ADDSETUP(FORM,IBCLINIC,NEW) ;
  1. ;NEW=1 if the form was just created, 0 otherwise
  1. N FLD,NODE,SETUP
  1. S NEW=+$G(NEW)
  1. K DA S DA=$O(^SD(409.95,"B",+$G(IBCLINIC),"")) I 'DA D
  1. .K DIC,DO,DD,DINUM S DIC="^SD(409.95,",DIC(0)="",X=IBCLINIC
  1. .D FILE^DICN K DIC
  1. .S DA=$S(+Y<1:0,1:+Y)
  1. Q:'DA
  1. S SETUP=DA,NODE=$G(^SD(409.95,SETUP,0))
  1. W !,"How should the clinic use the form?"
  1. K DIR
  1. 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;"
  1. S:NEW DIR(0)=DIR(0)_"7:WILL NOT BE USED BY CLINIC;"
  1. D ^DIR K DIR
  1. I (Y=-1)!(Y=7)!$D(DIRUT) Q
  1. S:Y'=2 FLD=$S(Y=1:.02,Y=3:.04,Y=4:.03,Y=5:.05,Y=6:.07,1:0)
  1. S:Y=2 FLD=$S('$P(NODE,"^",6):.06,'$P(NODE,"^",8):.08,1:.09)
  1. Q:'FLD
  1. I $P($G(^SD(409.95,DA,0)),"^",(100*FLD)) Q:'$$OVERLAY
  1. K DIE,DR S DIE=409.95
  1. S DR=FLD_"////"_FORM D ^DIE K DIE,DR,DA
  1. Q
  1. OVERLAY() ;asks the user if the he wants to overlay the form already used for the clinic setup
  1. W !,"But you already have a form for that use!"
  1. K DIR S DIR(0)="Y",DIR("A")="Do you want to replace it"
  1. D ^DIR K DIR
  1. Q:$D(DIRUT) 0
  1. Q Y