IBDF6.m

IBDF6 ;ALB/CJM - ENCOUNTER FORM - ENTRY FOR BUILDING A FORM ;NOV 16,1992

 ;;3.0;AUTOMATED INFO COLLECTION SYS;**10,29,30**;APR 24, 1997

 ;

FORMLIST ;

 N IBTKFORM,IBDEVICE,IBAPI,IOVL,IOHL,IOBRC,IOBLC,IOTRC,IOTLC,IBFORM

 ;IBDEVICE stores parameters related to device for printing forms

 D DEVICE^IBDFUA(1,.IBDEVICE)

 S IBTKFORM=0 ;IBTKFORM=1 only for toolkit forms

 S IBAPI("INDEX")="D IDXFORMS^IBDF6"

 S IBAPI("SELECT")="D SELECT^IBDF6"

 N IBFASTXT ;set to 1 for fast exit from system

 S IBFASTXT=0

 K XQORS,VALMEVL,DIR

 S IBCLINIC=""

 D CLINIC

 I IBCLINIC D EN^VALM("IBDF CLINIC FORM LIST")

 Q

ONENTRY ;

 D IDXFORMS

 Q

ONEXIT ;

 D KILL^%ZISS

 K ^TMP("IB",$J),^TMP("IBDF",$J),IBCLINIC,VALMY,IBQUIT,VALMBCK,X,Y,I,DA,D0

 Q

EDITFORM ;allows user to select a form, then displays it for edit

 N IBFORM,ARY,DFN,IBAPPT,RTNLIST,IBPRINT

 S ARY="^TMP(""IBDF"",$J,""TEMPORARY CLINIC LIST"")"

 ;

 K @ARY

 S VALMBCK=""

 I $G(IBAPI("SELECT"))'="" X IBAPI("SELECT")

 I IBFORM D CLINICS^IBDFU4(IBFORM,ARY) I $G(@ARY@(0))>1 W !,"The form is in use by other clinics!" D LIST^IBDFU4(ARY,4) S DIR(0)="Y",DIR("A")="Still want to edit",DIR("B")="N" D ^DIR K DIR I $D(DIRUT)!(Y=0) S IBFORM=""

 K ARY

 I IBFORM,'$$LOCKFRM2^IBDFU7(IBFORM) D LOCKMSG2^IBDFU7(IBFORM) S IBFORM=""

 I IBFORM D PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,1),UNCMPL^IBDF19(IBFORM,0),EN^VALM("IBDF DISPLAY FORM FOR EDIT"),UNCMPL^IBDF19(IBFORM,0),FREEFRM2^IBDFU7(IBFORM)

 S VALMBCK="R"

 Q

 ;

CLINIC ;

 N DIR,DIC,DIE,DR,DA

 S DIR(0)="409.95,.01",DIR("A")="EDIT FORMS FOR WHICH CLINIC? "

 D ^DIR

 K DIR

 I $D(DIRUT)!(+Y<0) Q

 S IBCLINIC=+Y

 Q

 ;

IDXFORMS ;build an array of forms used by IBCLINIC for the list processor

 N FORM,SETUP,NODE,SUB,SUBREC,USE,ID

 K @VALMAR

 S SETUP="",VALMCNT=0,ID=0

 S SETUP=$O(^SD(409.95,"B",IBCLINIC,"")) Q:'SETUP

 S NODE=$G(^SD(409.95,SETUP,0)) Q:NODE=""

 F SUB=2,6,8,9,3,4,5,7 S FORM=$P(NODE,"^",SUB) I FORM D

 .I $D(^IBE(357,FORM,0)) D

 ..S USE=""

 ..D ENTRY

 Q

ENTRY ;adds an entry to the array

 S USE=USE_$S(SUB=2:"Basic Encounter Form",SUB=3:"Supplemental Form - Established Patients",SUB=4:"Supplemental Form - New Patients",SUB=5:"Form To Print With No Patient Data",1:"")

 S:USE="" USE=USE_$S(SUB=7:"For Future Use",1:"Supplemental Form - All Patients")

 S ID=ID+1,VALMCNT=VALMCNT+1,@VALMAR@(VALMCNT,0)=$$DISPLAY1(FORM,USE,ID),@VALMAR@("IDX",VALMCNT,ID)=FORM D FLDCTRL^VALM10(VALMCNT) ;set video for ID column

 S VALMCNT=VALMCNT+1,@VALMAR@(VALMCNT,0)=$$DISPLAY2(FORM),@VALMAR@("IDX",VALMCNT,ID)=FORM_"^"_$S(SUB=2:.02,SUB=3:.03,SUB=4:.04,SUB=5:.05,SUB=6:.06,SUB=7:.07,SUB=8:.08,SUB=9:.09,1:0)

 Q

HDR ;

 S VALMHDR(1)="FORMS CURRENTLY USED BY '"_$$CLNCNAME_"' HOSPITAL LOCATION"

 Q

CLNCNAME() ;

 Q $P($G(^SC(IBCLINIC,0)),"^",1)

DISPLAY1(FORM,USE,ID) ;

 N NODE,NAME,RET

 S RET=$J(ID,3)_$$SP(2)

 S NODE=$G(^IBE(357,FORM,0))

 S NAME=$P(NODE,"^",1)

 S RET=RET_$$PR(NAME,30)_$$SP(2)_USE

 Q RET

DISPLAY2(FORM) ;

 N NODE,DESCR,RET

 S RET=$$SP(37)

 S NODE=$G(^IBE(357,FORM,0))

 S DESCR=$P(NODE,"^",3)

 S RET=RET_$E(DESCR,1,80)

 Q RET

PR(STR,LEN) ; pad right

 Q:'$G(LEN) ""

 N B S STR=$E($G(STR),1,LEN)

 S:LEN'=$L(STR) $P(B," ",LEN-$L($G(STR)))=" "

 Q STR_$G(B)

SP(LEN) ;

 Q:'$G(LEN)

 N S S $P(S," ",LEN)=" "

 Q S

CHNGCLNC ;allows the user to change the clinic

 N SAVECLNC S SAVECLNC=IBCLINIC

 D FULL^VALM1

 S VALMBCK="R"

 D CLINIC I 'IBCLINIC S IBCLINIC=SAVECLNC Q

 D HDR

 X IBAPI("INDEX")

 Q

 ;

SELECT  ;

 N SEL

 D EN^VALM2(XQORNOD(0),"S")

 S SEL=$O(VALMY(""))

 S IBFORM=$S('SEL:"",1:+$G(@VALMAR@("IDX",2*SEL,SEL)))

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBDF6   3591     printed  Feb 19, 2025@00:17:59                                                                                                                                                                                                       Page 2

IBDF6     ;ALB/CJM - ENCOUNTER FORM - ENTRY FOR BUILDING A FORM ;NOV 16,1992

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;**10,29,30**;APR 24, 1997

 +2       ;

FORMLIST  ;

 +1        NEW IBTKFORM,IBDEVICE,IBAPI,IOVL,IOHL,IOBRC,IOBLC,IOTRC,IOTLC,IBFORM

 +2       ;IBDEVICE stores parameters related to device for printing forms

 +3        DO DEVICE^IBDFUA(1,.IBDEVICE)

 +4       ;IBTKFORM=1 only for toolkit forms

           SET IBTKFORM=0

 +5        SET IBAPI("INDEX")="D IDXFORMS^IBDF6"

 +6        SET IBAPI("SELECT")="D SELECT^IBDF6"

 +7       ;set to 1 for fast exit from system

           NEW IBFASTXT

 +8        SET IBFASTXT=0

 +9        KILL XQORS,VALMEVL,DIR

 +10       SET IBCLINIC=""

 +11       DO CLINIC

 +12       IF IBCLINIC

               DO EN^VALM("IBDF CLINIC FORM LIST")

 +13       QUIT 

ONENTRY   ;

 +1        DO IDXFORMS

 +2        QUIT 

ONEXIT    ;

 +1        DO KILL^%ZISS

 +2        KILL ^TMP("IB",$JOB),^TMP("IBDF",$JOB),IBCLINIC,VALMY,IBQUIT,VALMBCK,X,Y,I,DA,D0

 +3        QUIT 

EDITFORM  ;allows user to select a form, then displays it for edit

 +1        NEW IBFORM,ARY,DFN,IBAPPT,RTNLIST,IBPRINT

 +2        SET ARY="^TMP(""IBDF"",$J,""TEMPORARY CLINIC LIST"")"

 +3       ;

 +4        KILL @ARY

 +5        SET VALMBCK=""

 +6        IF $GET(IBAPI("SELECT"))'=""

               XECUTE IBAPI("SELECT")

 +7        IF IBFORM

               DO CLINICS^IBDFU4(IBFORM,ARY)

               IF $GET(@ARY@(0))>1

                   WRITE !,"The form is in use by other clinics!"

                   DO LIST^IBDFU4(ARY,4)

                   SET DIR(0)="Y"

                   SET DIR("A")="Still want to edit"

                   SET DIR("B")="N"

                   DO ^DIR

                   KILL DIR

                   IF $DATA(DIRUT)!(Y=0)

                       SET IBFORM=""

 +8        KILL ARY

 +9        IF IBFORM

               IF '$$LOCKFRM2^IBDFU7(IBFORM)

                   DO LOCKMSG2^IBDFU7(IBFORM)

                   SET IBFORM=""

 +10       IF IBFORM

               DO PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,1)

               DO UNCMPL^IBDF19(IBFORM,0)

               DO EN^VALM("IBDF DISPLAY FORM FOR EDIT")

               DO UNCMPL^IBDF19(IBFORM,0)

               DO FREEFRM2^IBDFU7(IBFORM)

 +11       SET VALMBCK="R"

 +12       QUIT 

 +13      ;

CLINIC    ;

 +1        NEW DIR,DIC,DIE,DR,DA

 +2        SET DIR(0)="409.95,.01"

           SET DIR("A")="EDIT FORMS FOR WHICH CLINIC? "

 +3        DO ^DIR

 +4        KILL DIR

 +5        IF $DATA(DIRUT)!(+Y<0)

               QUIT 

 +6        SET IBCLINIC=+Y

 +7        QUIT 

 +8       ;

IDXFORMS  ;build an array of forms used by IBCLINIC for the list processor

 +1        NEW FORM,SETUP,NODE,SUB,SUBREC,USE,ID

 +2        KILL @VALMAR

 +3        SET SETUP=""

           SET VALMCNT=0

           SET ID=0

 +4        SET SETUP=$ORDER(^SD(409.95,"B",IBCLINIC,""))

           if 'SETUP

               QUIT 

 +5        SET NODE=$GET(^SD(409.95,SETUP,0))

           if NODE=""

               QUIT 

 +6        FOR SUB=2,6,8,9,3,4,5,7

               SET FORM=$PIECE(NODE,"^",SUB)

               IF FORM

                   Begin DoDot:1

 +7                    IF $DATA(^IBE(357,FORM,0))

                           Begin DoDot:2

 +8                            SET USE=""

 +9                            DO ENTRY

                           End DoDot:2

                   End DoDot:1

 +10       QUIT 

ENTRY     ;adds an entry to the array

 +1        SET USE=USE_$SELECT(SUB=2:"Basic Encounter Form",SUB=3:"Supplemental Form - Established Patients",SUB=4:"Supplemental Form - New Patients",SUB=5:"Form To Print With No Patient Data",1:"")

 +2        if USE=""

               SET USE=USE_$SELECT(SUB=7:"For Future Use",1:"Supplemental Form - All Patients")

 +3       ;set video for ID column

           SET ID=ID+1

           SET VALMCNT=VALMCNT+1

           SET @VALMAR@(VALMCNT,0)=$$DISPLAY1(FORM,USE,ID)

           SET @VALMAR@("IDX",VALMCNT,ID)=FORM

           DO FLDCTRL^VALM10(VALMCNT)

 +4        SET VALMCNT=VALMCNT+1

           SET @VALMAR@(VALMCNT,0)=$$DISPLAY2(FORM)

           SET @VALMAR@("IDX",VALMCNT,ID)=FORM_"^"_$SELECT(SUB=2:.02,SUB=3:.03,SUB=4:.04,SUB=5:.05,SUB=6:.06,SUB=7:.07,SUB=8:.08,SUB=9:.09,1:0)

 +5        QUIT 

HDR       ;

 +1        SET VALMHDR(1)="FORMS CURRENTLY USED BY '"_$$CLNCNAME_"' HOSPITAL LOCATION"

 +2        QUIT 

CLNCNAME() ;

 +1        QUIT $PIECE($GET(^SC(IBCLINIC,0)),"^",1)

DISPLAY1(FORM,USE,ID) ;

 +1        NEW NODE,NAME,RET

 +2        SET RET=$JUSTIFY(ID,3)_$$SP(2)

 +3        SET NODE=$GET(^IBE(357,FORM,0))

 +4        SET NAME=$PIECE(NODE,"^",1)

 +5        SET RET=RET_$$PR(NAME,30)_$$SP(2)_USE

 +6        QUIT RET

DISPLAY2(FORM) ;

 +1        NEW NODE,DESCR,RET

 +2        SET RET=$$SP(37)

 +3        SET NODE=$GET(^IBE(357,FORM,0))

 +4        SET DESCR=$PIECE(NODE,"^",3)

 +5        SET RET=RET_$EXTRACT(DESCR,1,80)

 +6        QUIT RET

PR(STR,LEN) ; pad right

 +1        if '$GET(LEN)

               QUIT ""

 +2        NEW B

           SET STR=$EXTRACT($GET(STR),1,LEN)

 +3        if LEN'=$LENGTH(STR)

               SET $PIECE(B," ",LEN-$LENGTH($GET(STR)))=" "

 +4        QUIT STR_$GET(B)

SP(LEN)   ;

 +1        if '$GET(LEN)

               QUIT 

 +2        NEW S

           SET $PIECE(S," ",LEN)=" "

 +3        QUIT S

CHNGCLNC  ;allows the user to change the clinic

 +1        NEW SAVECLNC

           SET SAVECLNC=IBCLINIC

 +2        DO FULL^VALM1

 +3        SET VALMBCK="R"

 +4        DO CLINIC

           IF 'IBCLINIC

               SET IBCLINIC=SAVECLNC

               QUIT 

 +5        DO HDR

 +6        XECUTE IBAPI("INDEX")

 +7        QUIT 

 +8       ;

SELECT    ;

 +1        NEW SEL

 +2        DO EN^VALM2(XQORNOD(0),"S")

 +3        SET SEL=$ORDER(VALMY(""))

 +4        SET IBFORM=$SELECT('SEL:"",1:+$GET(@VALMAR@("IDX",2*SEL,SEL)))

 +5        QUIT