- 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
- 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
