IBDFU2B ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(copying blocks - continued from IBDFU2) ; 08-JAN-1993
;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
;
CPYSLCTN(SLCTN,GRP,NEWGRP,LIST,NEWLIST,FROMFILE,TOFILE) ;
Q:('$G(SLCTN))!('$G(GRP))!('$G(NEWGRP))!('$G(LIST))!('$G(NEWLIST))!('$G(FROMFILE))!('$G(TOFILE))
Q:(FROMFILE'=357.3)&(FROMFILE'=358.3)
Q:(TOFILE'=357.3)&(TOFILE'=358.3)
N NODE,NAME,NEWSLCTN,SC,CNT,I
S NEWSLCTN=""
S NODE=$G(^IBE(FROMFILE,SLCTN,0)) Q:NODE=""
I ($P(NODE,"^",3)'=LIST)!($P(NODE,"^",4)'=GRP) K DA S DA=SLCTN,DIK="^IBE("_FROMFILE_"," D IX^DIK K DIK Q
S NAME=$P(NODE,"^",1),$P(NODE,"^",3)=NEWLIST,$P(NODE,"^",4)=NEWGRP
Q:NAME=""
K DIC,DD,DINUM,DO S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWSLCTN=$S(+Y<0:"",1:+Y)
Q:'NEWSLCTN
S ^IBE(TOFILE,NEWSLCTN,0)=NODE
;
; -- now copy the subcolumn value multiple
; -- When copying selections but not same list definition (i.e.
; when copying selections from one list to another)
; find old sub columns, in 357.2 for list
; find and match to new sub columns in 357.2 for new list
;
S (SC,CNT,LAST)=0
;S NODE=$G(^IBE(FROMFILE,SLCTN,1,0)) I NODE'="" S ^IBE(TOFILE,NEWSLCTN,1,0)=NODE
F S SC=$O(^IBE(FROMFILE,SLCTN,1,SC)) Q:'SC S NODE=$G(^IBE(FROMFILE,SLCTN,1,SC,0)) D:$D(IBDFCPYF) S:NODE'="" ^IBE(TOFILE,NEWSLCTN,1,+NODE,0)=NODE,CNT=CNT+1,LAST=+NODE
.N K,IBDFI
.S K=0,IBDFI=+NODE
.Q:$G(IBDFNEW(IBDFI))=$G(IBDFOLD(IBDFI))
.F S K=$O(IBDFNEW(K)) Q:K="" I IBDFNEW(K)=$G(IBDFOLD(+IBDFI)) S $P(NODE,"^",1)=K,NODE=NODE Q
.Q
S ^IBE(TOFILE,NEWSLCTN,1,0)=$S(TOFILE=357.3:"^357.31IA^",1:"^358.31IA^")_$G(LAST)_"^"_CNT
; -- now copy 2 node if it exists
S NODE=$G(^IBE(FROMFILE,SLCTN,2))
I NODE'="" S ^IBE(TOFILE,NEWSLCTN,2)=NODE
;
; -- now copy 3 node if it exists (CPT MODIFIERS)
;
I $D(^IBE(FROMFILE,SLCTN,3)) D
. S ^IBE(TOFILE,NEWSLCTN,3,0)=^IBE(FROMFILE,SLCTN,3,0)
. F I=0:0 S I=$O(^IBE(FROMFILE,SLCTN,3,I)) Q:'I D
.. S:$D(^IBE(FROMFILE,SLCTN,3,I,0)) ^IBE(TOFILE,NEWSLCTN,3,I,0)=^(0)
;
; -- now re-index file entry
;
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWSLCTN
D IX1^DIK
K DIK,DA
Q
;
GETMA(MA,FROMFILE,TOFILE) ;copys marking area=ma from file=FROMFILE to file=TOFILE if it does not already exist
;returns the ien of the marking area existing in TOFILE
Q:($G(FROMFILE)'=357.91)&($G(FROMFILE)'=358.91) ""
Q:($G(TOFILE)'=357.91)&($G(TOFILE)'=358.91) ""
Q:'$G(MA) ""
Q:FROMFILE=TOFILE MA ;files are the same!
N NODE,NAME,NEWMA
S NEWMA=""
S NODE=$G(^IBE(FROMFILE,MA,0)) Q:NODE="" ""
S NAME=$P(NODE,"^",1)
Q:NAME="" ""
S NEWMA=$O(^IBE(TOFILE,"B",NAME,0)) Q:NEWMA NEWMA ;quit if it already exists
K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWMA=$S(+Y<0:"",1:+Y)
Q:'NEWMA ""
S ^IBE(TOFILE,NEWMA,0)=NODE
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWMA
D IX1^DIK K DIK,DA
Q NEWMA
;
GETPI(PI,FROMFILE,TOFILE) ;copies the package interface=PI from file=FROMFILE to file=TOFILE if it doesn't already exist
;returns the ien of the package interface in the TOFILE
Q:($G(FROMFILE)'=357.6)&($G(FROMFILE)'=358.6) ""
Q:($G(TOFILE)'=357.6)&($G(TOFILE)'=358.6) ""
Q:'$G(PI) ""
Q:FROMFILE=TOFILE PI
N NODE,NEWPI,SUB1,SUB2,RTN,ENTRYPT,TYPE
S NEWPI=""
S NODE=$G(^IBE(FROMFILE,PI,0)) Q:NODE="" ""
S NAME=$P(NODE,"^"),ENTRYPT=$P(NODE,"^",2),RTN=$P(NODE,"^",3),TYPE=$P(NODE,"^",6)
S NEWPI=$$LOOKUP(NAME,RTN,ENTRYPT,TOFILE,TYPE)
Q:NEWPI NEWPI ;quit if copy is not needed
K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=$P(NODE,"^"),DIC(0)=""
Q:X="" "" ;corrupted data!
D FILE^DICN K DIC,DIE,DA
S NEWPI=$S(+Y<0:"",1:+Y)
Q:'NEWPI ""
;
;for display or selection interfaces, if the entry point does not exist the new package interface should be marked as unavailable
I (TYPE=2)!(TYPE=3) D
.I RTN="" S $P(NODE,"^",9)=0 Q
.I RTN'="" D
..I ENTRYPT]"" I '$L($T(@ENTRYPT^@RTN)) S $P(NODE,"^",9)=0
..I ENTRYPT="" I '$L($T(^@RTN)) S $P(NODE,"^",9)=0
;
S ^IBE(TOFILE,NEWPI,0)=NODE
S:$P(NODE,"^",13) $P(NODE,"^",13)=$$GETPI($P(NODE,"^",13),$S(FROMFILE[358:358.6,1:357.6),$S(TOFILE[358:358.6,1:357.6))
S ^IBE(TOFILE,NEWPI,0)=NODE
F SUB1=2,3,4,5,8,9,10,11,12,14,17,18,19,20,21 S NODE=$G(^IBE(FROMFILE,PI,SUB1)) I NODE'="" S ^IBE(TOFILE,NEWPI,SUB1)=NODE
S NODE=$G(^IBE(FROMFILE,PI,16)) I NODE'="" D
.N TYPEDATA
.S TYPEDATA=$P(NODE,"^",2)
.I TYPEDATA S $P(NODE,"^",2)=$$GETADE(TYPEDATA,$S(FROMFILE[358:358.99,1:359.1),$S(TOFILE[358:358.99,1:359.1))
.S TYPEDATA=$P(NODE,"^",6)
.I TYPEDATA S $P(NODE,"^",6)=$$GETADE(TYPEDATA,$S(FROMFILE[358:358.99,1:359.1),$S(TOFILE[358:358.99,1:359.1))
.S ^IBE(TOFILE,NEWPI,16)=NODE
F SUB1=1,6,7,15 S NODE=$G(^IBE(FROMFILE,PI,SUB1,0)) D
.I NODE'="" S ^IBE(TOFILE,NEWPI,SUB1,0)=NODE S SUB2=0 F S SUB2=$O(^IBE(FROMFILE,PI,SUB1,SUB2)) Q:'SUB2 S NODE=$G(^IBE(FROMFILE,PI,SUB1,SUB2,0)) I NODE'="" S ^IBE(TOFILE,NEWPI,SUB1,SUB2,0)=NODE
;
D CPYQLFRS(FROMFILE,PI,TOFILE,NEWPI)
;
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWPI
D IX1^DIK K DIK,DA
Q NEWPI
;
CPYQLFRS(FROMFILE,PI,TOFILE,NEWPI) ;copy allowable qualifiers from the package interface=PI in NEWPI to the package interface=NEWPI in TOFILE
;
N NODE,SUB,VARPTR
K ^IBE(TOFILE,NEWPI,13)
S NODE=$G(^IBE(FROMFILE,PI,13,0)) I NODE'="" S ^IBE(TOFILE,NEWPI,13,0)=NODE S SUB=0 F S SUB=$O(^IBE(FROMFILE,PI,13,SUB)) Q:'SUB D
.S NODE=$G(^IBE(FROMFILE,PI,13,SUB,0)),VARPTR=$P(NODE,"^") I +VARPTR D I +VARPTR S $P(NODE,"^")=VARPTR,^IBE(TOFILE,NEWPI,13,SUB,0)=NODE
..I VARPTR["IBE" S $P(VARPTR,";")=$$GETADE(+VARPTR,$S(FROMFILE[358:358.99,1:359.1),$S(TOFILE[358:358.99,1:359.1)),$P(VARPTR,"(",2)=$S(TOFILE[358:358.99,1:359.1)_"," Q
..I VARPTR["IBD" S $P(VARPTR,";")=$$GETQLFR(+VARPTR,$S(FROMFILE[358:358.98,1:357.98),$S(TOFILE[358:358.98,1:357.98)),$P(VARPTR,"(",2)=$S(TOFILE[358:358.98,1:357.98)_","
Q
;
LOOKUP(NAME,RTN,ENTRYPT,TOFILE,TYPE) ;return 1 if the package interface already exists in TOFILE, 0 otherwise
N PI,LOOKNODE,QUIT
Q:NAME="" ""
S (QUIT,PI)=0 F S PI=$O(^IBE(TOFILE,"B",$E(NAME,1,30),PI)) Q:'PI S LOOKNODE=$G(^IBE(TOFILE,PI,0)) I LOOKNODE'="" D Q:QUIT
.I NAME=$P(LOOKNODE,"^"),RTN=$P(LOOKNODE,"^",3),ENTRYPT=$P(LOOKNODE,"^",2),TYPE=$P(LOOKNODE,"^",6) S QUIT=1 Q ;matches!
Q PI
;
GETQLFR(QLFR,FROMFILE,TOFILE) ;copys qualifier=QLFR from file=FROMFILE to file=TOFILE if it does not already exist
;returns the ien of the qualifier existing in TOFILE
Q:($G(FROMFILE)'=357.98)&($G(FROMFILE)'=358.98) ""
Q:($G(TOFILE)'=357.98)&($G(TOFILE)'=358.98) ""
Q:'$G(QLFR) ""
Q:FROMFILE=TOFILE QLFR ;files are the same!
N NODE,NAME,NEWQLFR
S NEWQLFR=""
S NODE=$G(^IBD(FROMFILE,QLFR,0)) Q:NODE="" ""
S NAME=$P(NODE,"^",1)
Q:NAME="" ""
;does it already exist?
S NEWQLFR=0 F S NEWQLFR=$O(^IBD(TOFILE,"B",$E(NAME,1,30),NEWQLFR)) Q:'NEWQLFR Q:$P($G(^IBD(TOFILE,NEWQLFR,0)),"^")=NAME
Q:NEWQLFR NEWQLFR ;quit if it already exists
K DIC,DO,DINUM,DD S DIC="^IBD("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWQLFR=$S(+Y<0:"",1:+Y)
Q:'NEWQLFR ""
S ^IBD(TOFILE,NEWQLFR,0)=NODE
K DIK,DA S DIK="^IBD("_TOFILE_",",DA=NEWQLFR
D IX1^DIK K DIK,DA
Q NEWQLFR
;
GETADE(ADE,FROMFILE,TOFILE) ;copys AICS Data Element=ADE from file=FROMFILE to file=TOFILE if it does not already exist
;returns the ien of the qualifier existing in TOFILE
Q:($G(FROMFILE)'=359.1)&($G(FROMFILE)'=358.99) ""
Q:($G(TOFILE)'=359.1)&($G(TOFILE)'=358.99) ""
Q:'$G(ADE) ""
Q:FROMFILE=TOFILE ADE ;files are the same!
N NODE,NAME,NEWADE,SUB
S NEWADE=""
S NODE=$G(^IBE(FROMFILE,ADE,0)) Q:NODE="" ""
S NAME=$P(NODE,"^",1)
Q:NAME="" ""
S NEWADE=$O(^IBE(TOFILE,"B",NAME,0)) Q:NEWADE NEWADE ;quit if it already exists
K DIC,DO,DINUM,DD S DIC="^IBE("_TOFILE_",",X=NAME,DIC(0)=""
D FILE^DICN K DIC,DIE,DA
S NEWADE=$S(+Y<0:"",1:+Y)
Q:'NEWADE ""
S ^IBE(TOFILE,NEWADE,0)=NODE
;
; -- 9/28/95 add 10 node to be moved for moved fields
F SUB=1,2,3,10 S NODE=$G(^IBE(FROMFILE,ADE,SUB)) I NODE'="" S ^IBE(TOFILE,NEWADE,SUB)=NODE
K DIK,DA S DIK="^IBE("_TOFILE_",",DA=NEWADE
D IX1^DIK K DIK,DA
Q NEWADE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU2B 8171 printed Apr 09, 2024@21:43:05 Page 2
IBDFU2B ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(copying blocks - continued from IBDFU2) ; 08-JAN-1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
+2 ;
CPYSLCTN(SLCTN,GRP,NEWGRP,LIST,NEWLIST,FROMFILE,TOFILE) ;
+1 if ('$GET(SLCTN))!('$GET(GRP))!('$GET(NEWGRP))!('$GET(LIST))!('$GET(NEWLIST))!('$GET(FROMFILE))!('$GET(TOFILE))
QUIT
+2 if (FROMFILE'=357.3)&(FROMFILE'=358.3)
QUIT
+3 if (TOFILE'=357.3)&(TOFILE'=358.3)
QUIT
+4 NEW NODE,NAME,NEWSLCTN,SC,CNT,I
+5 SET NEWSLCTN=""
+6 SET NODE=$GET(^IBE(FROMFILE,SLCTN,0))
if NODE=""
QUIT
+7 IF ($PIECE(NODE,"^",3)'=LIST)!($PIECE(NODE,"^",4)'=GRP)
KILL DA
SET DA=SLCTN
SET DIK="^IBE("_FROMFILE_","
DO IX^DIK
KILL DIK
QUIT
+8 SET NAME=$PIECE(NODE,"^",1)
SET $PIECE(NODE,"^",3)=NEWLIST
SET $PIECE(NODE,"^",4)=NEWGRP
+9 if NAME=""
QUIT
+10 KILL DIC,DD,DINUM,DO
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+11 DO FILE^DICN
KILL DIC,DIE,DA
+12 SET NEWSLCTN=$SELECT(+Y<0:"",1:+Y)
+13 if 'NEWSLCTN
QUIT
+14 SET ^IBE(TOFILE,NEWSLCTN,0)=NODE
+15 ;
+16 ; -- now copy the subcolumn value multiple
+17 ; -- When copying selections but not same list definition (i.e.
+18 ; when copying selections from one list to another)
+19 ; find old sub columns, in 357.2 for list
+20 ; find and match to new sub columns in 357.2 for new list
+21 ;
+22 SET (SC,CNT,LAST)=0
+23 ;S NODE=$G(^IBE(FROMFILE,SLCTN,1,0)) I NODE'="" S ^IBE(TOFILE,NEWSLCTN,1,0)=NODE
+24 FOR
SET SC=$ORDER(^IBE(FROMFILE,SLCTN,1,SC))
if 'SC
QUIT
SET NODE=$GET(^IBE(FROMFILE,SLCTN,1,SC,0))
if $DATA(IBDFCPYF)
Begin DoDot:1
+25 NEW K,IBDFI
+26 SET K=0
SET IBDFI=+NODE
+27 if $GET(IBDFNEW(IBDFI))=$GET(IBDFOLD(IBDFI))
QUIT
+28 FOR
SET K=$ORDER(IBDFNEW(K))
if K=""
QUIT
IF IBDFNEW(K)=$GET(IBDFOLD(+IBDFI))
SET $PIECE(NODE,"^",1)=K
SET NODE=NODE
QUIT
+29 QUIT
End DoDot:1
if NODE'=""
SET ^IBE(TOFILE,NEWSLCTN,1,+NODE,0)=NODE
SET CNT=CNT+1
SET LAST=+NODE
+30 SET ^IBE(TOFILE,NEWSLCTN,1,0)=$SELECT(TOFILE=357.3:"^357.31IA^",1:"^358.31IA^")_$GET(LAST)_"^"_CNT
+31 ; -- now copy 2 node if it exists
+32 SET NODE=$GET(^IBE(FROMFILE,SLCTN,2))
+33 IF NODE'=""
SET ^IBE(TOFILE,NEWSLCTN,2)=NODE
+34 ;
+35 ; -- now copy 3 node if it exists (CPT MODIFIERS)
+36 ;
+37 IF $DATA(^IBE(FROMFILE,SLCTN,3))
Begin DoDot:1
+38 SET ^IBE(TOFILE,NEWSLCTN,3,0)=^IBE(FROMFILE,SLCTN,3,0)
+39 FOR I=0:0
SET I=$ORDER(^IBE(FROMFILE,SLCTN,3,I))
if 'I
QUIT
Begin DoDot:2
+40 if $DATA(^IBE(FROMFILE,SLCTN,3,I,0))
SET ^IBE(TOFILE,NEWSLCTN,3,I,0)=^(0)
End DoDot:2
End DoDot:1
+41 ;
+42 ; -- now re-index file entry
+43 ;
+44 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWSLCTN
+45 DO IX1^DIK
+46 KILL DIK,DA
+47 QUIT
+48 ;
GETMA(MA,FROMFILE,TOFILE) ;copys marking area=ma from file=FROMFILE to file=TOFILE if it does not already exist
+1 ;returns the ien of the marking area existing in TOFILE
+2 if ($GET(FROMFILE)'=357.91)&($GET(FROMFILE)'=358.91)
QUIT ""
+3 if ($GET(TOFILE)'=357.91)&($GET(TOFILE)'=358.91)
QUIT ""
+4 if '$GET(MA)
QUIT ""
+5 ;files are the same!
if FROMFILE=TOFILE
QUIT MA
+6 NEW NODE,NAME,NEWMA
+7 SET NEWMA=""
+8 SET NODE=$GET(^IBE(FROMFILE,MA,0))
if NODE=""
QUIT ""
+9 SET NAME=$PIECE(NODE,"^",1)
+10 if NAME=""
QUIT ""
+11 ;quit if it already exists
SET NEWMA=$ORDER(^IBE(TOFILE,"B",NAME,0))
if NEWMA
QUIT NEWMA
+12 KILL DIC,DO,DINUM,DD
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+13 DO FILE^DICN
KILL DIC,DIE,DA
+14 SET NEWMA=$SELECT(+Y<0:"",1:+Y)
+15 if 'NEWMA
QUIT ""
+16 SET ^IBE(TOFILE,NEWMA,0)=NODE
+17 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWMA
+18 DO IX1^DIK
KILL DIK,DA
+19 QUIT NEWMA
+20 ;
GETPI(PI,FROMFILE,TOFILE) ;copies the package interface=PI from file=FROMFILE to file=TOFILE if it doesn't already exist
+1 ;returns the ien of the package interface in the TOFILE
+2 if ($GET(FROMFILE)'=357.6)&($GET(FROMFILE)'=358.6)
QUIT ""
+3 if ($GET(TOFILE)'=357.6)&($GET(TOFILE)'=358.6)
QUIT ""
+4 if '$GET(PI)
QUIT ""
+5 if FROMFILE=TOFILE
QUIT PI
+6 NEW NODE,NEWPI,SUB1,SUB2,RTN,ENTRYPT,TYPE
+7 SET NEWPI=""
+8 SET NODE=$GET(^IBE(FROMFILE,PI,0))
if NODE=""
QUIT ""
+9 SET NAME=$PIECE(NODE,"^")
SET ENTRYPT=$PIECE(NODE,"^",2)
SET RTN=$PIECE(NODE,"^",3)
SET TYPE=$PIECE(NODE,"^",6)
+10 SET NEWPI=$$LOOKUP(NAME,RTN,ENTRYPT,TOFILE,TYPE)
+11 ;quit if copy is not needed
if NEWPI
QUIT NEWPI
+12 KILL DIC,DO,DINUM,DD
SET DIC="^IBE("_TOFILE_","
SET X=$PIECE(NODE,"^")
SET DIC(0)=""
+13 ;corrupted data!
if X=""
QUIT ""
+14 DO FILE^DICN
KILL DIC,DIE,DA
+15 SET NEWPI=$SELECT(+Y<0:"",1:+Y)
+16 if 'NEWPI
QUIT ""
+17 ;
+18 ;for display or selection interfaces, if the entry point does not exist the new package interface should be marked as unavailable
+19 IF (TYPE=2)!(TYPE=3)
Begin DoDot:1
+20 IF RTN=""
SET $PIECE(NODE,"^",9)=0
QUIT
+21 IF RTN'=""
Begin DoDot:2
+22 IF ENTRYPT]""
IF '$LENGTH($TEXT(@ENTRYPT^@RTN))
SET $PIECE(NODE,"^",9)=0
+23 IF ENTRYPT=""
IF '$LENGTH($TEXT(^@RTN))
SET $PIECE(NODE,"^",9)=0
End DoDot:2
End DoDot:1
+24 ;
+25 SET ^IBE(TOFILE,NEWPI,0)=NODE
+26 if $PIECE(NODE,"^",13)
SET $PIECE(NODE,"^",13)=$$GETPI($PIECE(NODE,"^",13),$SELECT(FROMFILE[358:358.6,1:357.6),$SELECT(TOFILE[358:358.6,1:357.6))
+27 SET ^IBE(TOFILE,NEWPI,0)=NODE
+28 FOR SUB1=2,3,4,5,8,9,10,11,12,14,17,18,19,20,21
SET NODE=$GET(^IBE(FROMFILE,PI,SUB1))
IF NODE'=""
SET ^IBE(TOFILE,NEWPI,SUB1)=NODE
+29 SET NODE=$GET(^IBE(FROMFILE,PI,16))
IF NODE'=""
Begin DoDot:1
+30 NEW TYPEDATA
+31 SET TYPEDATA=$PIECE(NODE,"^",2)
+32 IF TYPEDATA
SET $PIECE(NODE,"^",2)=$$GETADE(TYPEDATA,$SELECT(FROMFILE[358:358.99,1:359.1),$SELECT(TOFILE[358:358.99,1:359.1))
+33 SET TYPEDATA=$PIECE(NODE,"^",6)
+34 IF TYPEDATA
SET $PIECE(NODE,"^",6)=$$GETADE(TYPEDATA,$SELECT(FROMFILE[358:358.99,1:359.1),$SELECT(TOFILE[358:358.99,1:359.1))
+35 SET ^IBE(TOFILE,NEWPI,16)=NODE
End DoDot:1
+36 FOR SUB1=1,6,7,15
SET NODE=$GET(^IBE(FROMFILE,PI,SUB1,0))
Begin DoDot:1
+37 IF NODE'=""
SET ^IBE(TOFILE,NEWPI,SUB1,0)=NODE
SET SUB2=0
FOR
SET SUB2=$ORDER(^IBE(FROMFILE,PI,SUB1,SUB2))
if 'SUB2
QUIT
SET NODE=$GET(^IBE(FROMFILE,PI,SUB1,SUB2,0))
IF NODE'=""
SET ^IBE(TOFILE,NEWPI,SUB1,SUB2,0)=NODE
End DoDot:1
+38 ;
+39 DO CPYQLFRS(FROMFILE,PI,TOFILE,NEWPI)
+40 ;
+41 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWPI
+42 DO IX1^DIK
KILL DIK,DA
+43 QUIT NEWPI
+44 ;
CPYQLFRS(FROMFILE,PI,TOFILE,NEWPI) ;copy allowable qualifiers from the package interface=PI in NEWPI to the package interface=NEWPI in TOFILE
+1 ;
+2 NEW NODE,SUB,VARPTR
+3 KILL ^IBE(TOFILE,NEWPI,13)
+4 SET NODE=$GET(^IBE(FROMFILE,PI,13,0))
IF NODE'=""
SET ^IBE(TOFILE,NEWPI,13,0)=NODE
SET SUB=0
FOR
SET SUB=$ORDER(^IBE(FROMFILE,PI,13,SUB))
if 'SUB
QUIT
Begin DoDot:1
+5 SET NODE=$GET(^IBE(FROMFILE,PI,13,SUB,0))
SET VARPTR=$PIECE(NODE,"^")
IF +VARPTR
Begin DoDot:2
+6 IF VARPTR["IBE"
SET $PIECE(VARPTR,";")=$$GETADE(+VARPTR,$SELECT(FROMFILE[358:358.99,1:359.1),$SELECT(TOFILE[358:358.99,1:359.1))
SET $PIECE(VARPTR,"(",2)=$SELECT(TOFILE[358:358.99,1:359.1)_","
QUIT
+7 IF VARPTR["IBD"
SET $PIECE(VARPTR,";")=$$GETQLFR(+VARPTR,$SELECT(FROMFILE[358:358.98,1:357.98),$SELECT(TOFILE[358:358.98,1:357.98))
SET $PIECE(VARPTR,"(",2)=$SELECT(TOFILE[358:358.98,1:357.98)_","
End DoDot:2
IF +VARPTR
SET $PIECE(NODE,"^")=VARPTR
SET ^IBE(TOFILE,NEWPI,13,SUB,0)=NODE
End DoDot:1
+8 QUIT
+9 ;
LOOKUP(NAME,RTN,ENTRYPT,TOFILE,TYPE) ;return 1 if the package interface already exists in TOFILE, 0 otherwise
+1 NEW PI,LOOKNODE,QUIT
+2 if NAME=""
QUIT ""
+3 SET (QUIT,PI)=0
FOR
SET PI=$ORDER(^IBE(TOFILE,"B",$EXTRACT(NAME,1,30),PI))
if 'PI
QUIT
SET LOOKNODE=$GET(^IBE(TOFILE,PI,0))
IF LOOKNODE'=""
Begin DoDot:1
+4 ;matches!
IF NAME=$PIECE(LOOKNODE,"^")
IF RTN=$PIECE(LOOKNODE,"^",3)
IF ENTRYPT=$PIECE(LOOKNODE,"^",2)
IF TYPE=$PIECE(LOOKNODE,"^",6)
SET QUIT=1
QUIT
End DoDot:1
if QUIT
QUIT
+5 QUIT PI
+6 ;
GETQLFR(QLFR,FROMFILE,TOFILE) ;copys qualifier=QLFR from file=FROMFILE to file=TOFILE if it does not already exist
+1 ;returns the ien of the qualifier existing in TOFILE
+2 if ($GET(FROMFILE)'=357.98)&($GET(FROMFILE)'=358.98)
QUIT ""
+3 if ($GET(TOFILE)'=357.98)&($GET(TOFILE)'=358.98)
QUIT ""
+4 if '$GET(QLFR)
QUIT ""
+5 ;files are the same!
if FROMFILE=TOFILE
QUIT QLFR
+6 NEW NODE,NAME,NEWQLFR
+7 SET NEWQLFR=""
+8 SET NODE=$GET(^IBD(FROMFILE,QLFR,0))
if NODE=""
QUIT ""
+9 SET NAME=$PIECE(NODE,"^",1)
+10 if NAME=""
QUIT ""
+11 ;does it already exist?
+12 SET NEWQLFR=0
FOR
SET NEWQLFR=$ORDER(^IBD(TOFILE,"B",$EXTRACT(NAME,1,30),NEWQLFR))
if 'NEWQLFR
QUIT
if $PIECE($GET(^IBD(TOFILE,NEWQLFR,0)),"^")=NAME
QUIT
+13 ;quit if it already exists
if NEWQLFR
QUIT NEWQLFR
+14 KILL DIC,DO,DINUM,DD
SET DIC="^IBD("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+15 DO FILE^DICN
KILL DIC,DIE,DA
+16 SET NEWQLFR=$SELECT(+Y<0:"",1:+Y)
+17 if 'NEWQLFR
QUIT ""
+18 SET ^IBD(TOFILE,NEWQLFR,0)=NODE
+19 KILL DIK,DA
SET DIK="^IBD("_TOFILE_","
SET DA=NEWQLFR
+20 DO IX1^DIK
KILL DIK,DA
+21 QUIT NEWQLFR
+22 ;
GETADE(ADE,FROMFILE,TOFILE) ;copys AICS Data Element=ADE from file=FROMFILE to file=TOFILE if it does not already exist
+1 ;returns the ien of the qualifier existing in TOFILE
+2 if ($GET(FROMFILE)'=359.1)&($GET(FROMFILE)'=358.99)
QUIT ""
+3 if ($GET(TOFILE)'=359.1)&($GET(TOFILE)'=358.99)
QUIT ""
+4 if '$GET(ADE)
QUIT ""
+5 ;files are the same!
if FROMFILE=TOFILE
QUIT ADE
+6 NEW NODE,NAME,NEWADE,SUB
+7 SET NEWADE=""
+8 SET NODE=$GET(^IBE(FROMFILE,ADE,0))
if NODE=""
QUIT ""
+9 SET NAME=$PIECE(NODE,"^",1)
+10 if NAME=""
QUIT ""
+11 ;quit if it already exists
SET NEWADE=$ORDER(^IBE(TOFILE,"B",NAME,0))
if NEWADE
QUIT NEWADE
+12 KILL DIC,DO,DINUM,DD
SET DIC="^IBE("_TOFILE_","
SET X=NAME
SET DIC(0)=""
+13 DO FILE^DICN
KILL DIC,DIE,DA
+14 SET NEWADE=$SELECT(+Y<0:"",1:+Y)
+15 if 'NEWADE
QUIT ""
+16 SET ^IBE(TOFILE,NEWADE,0)=NODE
+17 ;
+18 ; -- 9/28/95 add 10 node to be moved for moved fields
+19 FOR SUB=1,2,3,10
SET NODE=$GET(^IBE(FROMFILE,ADE,SUB))
IF NODE'=""
SET ^IBE(TOFILE,NEWADE,SUB)=NODE
+20 KILL DIK,DA
SET DIK="^IBE("_TOFILE_","
SET DA=NEWADE
+21 DO IX1^DIK
KILL DIK,DA
+22 QUIT NEWADE
