IBDF18D ;ALB/CJM/AAS - ENCOUNTER FORM - form type utilities ;04-OCT-94
;;3.0;AUTOMATED INFO COLLECTION SYS;**5**;APR 24, 1997
;
FORMTYPE(SOURCE) ;creates an entry in the FORM DEFINITION TABLE
; -- input SOURCE = the source of the form, ie
; IB=1
; PANDAS=2
; TELEFORM=3
; OTHER=99
; -- Output Returns the ien of the table created, "" if not created
;
Q:'SOURCE ""
N IBFORMID,ID,NODE,DIC,DIE,DA,DINUM,D0,DD,DIK,DINUM,DLAYGO
S ID=""
;
L +^IBD(357.97,1,.01):3
S ID=$P($G(^IBD(357.97,1,0)),"^")
K DIC,D0,DD,DA,DO
S DIC="^IBD(357.95,",DIC(0)="L",DLAYGO=357.95
F ID=ID+1:1 L:$D(^IBD(357.95,(ID-1))) -^IBD(357.95,(ID-1)) I ID>0,'$D(^IBD(357.95,ID)) L +^IBD(357.95,ID):1 I $T,'$D(^IBD(357.95,ID)) S (X,DINUM)=ID D FILE^DICN I +Y>0 L -^IBD(357.95,ID) Q
S $P(^IBD(357.97,1,0),"^")=ID
L -^IBD(357.97,1,.01)
K DIC,DIE,DA,DINUM,DLAYGO,DO,D0,DD
S IBFORMID=$S(+Y<0:"",1:+Y) I 'IBFORMID D LOGERR^IBDF18E2(3570003)
;
I IBFORMID D
.S $P(^IBD(357.95,IBFORMID,0),"^",3)=SOURCE,^IBD(357.95,IBFORMID,1,0)="^357.951I^0^0",^IBD(357.95,IBFORMID,2,0)="^357.952I^0^0",^IBD(357.95,IBFORMID,3,0)="^357.953^0^0"
.S DIK="^IBD(357.95,",DA=IBFORMID D IX1^DIK
K DIK,X,DA
Q IBFORMID
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF18D 1287 printed Dec 13, 2024@02:50:54 Page 2
IBDF18D ;ALB/CJM/AAS - ENCOUNTER FORM - form type utilities ;04-OCT-94
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**5**;APR 24, 1997
+2 ;
FORMTYPE(SOURCE) ;creates an entry in the FORM DEFINITION TABLE
+1 ; -- input SOURCE = the source of the form, ie
+2 ; IB=1
+3 ; PANDAS=2
+4 ; TELEFORM=3
+5 ; OTHER=99
+6 ; -- Output Returns the ien of the table created, "" if not created
+7 ;
+8 if 'SOURCE
QUIT ""
+9 NEW IBFORMID,ID,NODE,DIC,DIE,DA,DINUM,D0,DD,DIK,DINUM,DLAYGO
+10 SET ID=""
+11 ;
+12 LOCK +^IBD(357.97,1,.01):3
+13 SET ID=$PIECE($GET(^IBD(357.97,1,0)),"^")
+14 KILL DIC,D0,DD,DA,DO
+15 SET DIC="^IBD(357.95,"
SET DIC(0)="L"
SET DLAYGO=357.95
+16 FOR ID=ID+1:1
if $DATA(^IBD(357.95,(ID-1)))
LOCK -^IBD(357.95,(ID-1))
IF ID>0
IF '$DATA(^IBD(357.95,ID))
LOCK +^IBD(357.95,ID):1
IF $TEST
IF '$DATA(^IBD(357.95,ID))
SET (X,DINUM)=ID
DO FILE^DICN
IF +Y>0
LOCK -^IBD(357.95,ID)
QUIT
+17 SET $PIECE(^IBD(357.97,1,0),"^")=ID
+18 LOCK -^IBD(357.97,1,.01)
+19 KILL DIC,DIE,DA,DINUM,DLAYGO,DO,D0,DD
+20 SET IBFORMID=$SELECT(+Y<0:"",1:+Y)
IF 'IBFORMID
DO LOGERR^IBDF18E2(3570003)
+21 ;
+22 IF IBFORMID
Begin DoDot:1
+23 SET $PIECE(^IBD(357.95,IBFORMID,0),"^",3)=SOURCE
SET ^IBD(357.95,IBFORMID,1,0)="^357.951I^0^0"
SET ^IBD(357.95,IBFORMID,2,0)="^357.952I^0^0"
SET ^IBD(357.95,IBFORMID,3,0)="^357.953^0^0"
+24 SET DIK="^IBD(357.95,"
SET DA=IBFORMID
DO IX1^DIK
End DoDot:1
+25 KILL DIK,X,DA
+26 QUIT IBFORMID
