- 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 Jan 18, 2025@03:52:46 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