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 ---[H[J[2J[HIBDF6 3591 printed Apr 09, 2024@21:10:44 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
