- 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 Feb 19, 2025@00:17:20 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