- XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13
- ;;8.0;KERNEL;**201,302,393,498,1009,1013,1016**;Jul 10, 1995;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified.
- Q
- ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root
- ;XPDNM=package name, XPDA=ien in ^XPD(9.6,
- ;DA=ien in file, OLDA= ien in ^XTMP
- ;
- PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51
- ;Now load any entries from 8989.5
- N XP1,XP2,XP3,DIK,OLDA,DA,ERR,PN,PE,PT,ROOT
- S XP1=$O(^XTMP("XPDI",XPDA,"PKG",0)) ;Get the package
- Q:'XP1 S PN=$G(^XTMP("XPDI",XPDA,"PKG",XP1,0))
- S PE=$$FIND1^DIC(9.4,,"MX",$P(PN,U,2)) ;Get the IEN of the package
- S OLDA=0,ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.5))
- F S OLDA=$O(@ROOT@(OLDA)) Q:'OLDA D
- . S XP1=@ROOT@(OLDA,0)
- . S $P(XP1,U,1)=PE_";DIC(9.4," ;entity
- . S $P(XP1,U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),$P(XP1,U,2))
- . S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3))
- . ;Remove the current entry if we have one
- . I DA>0 S DIK="^XTV(8989.5," D ^DIK
- . ;Otherwise Add the zero node, See that we have a IEN
- . I DA'>0 D ADDPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3)) S DA=$$LKPAR($P(XP1,U),$P(XP1,U,2),$P(XP1,U,3))
- . Q:'DA ;don't have a entry
- . ;Merge the date ;with IHS fix
- . M ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA)
- . S ^XTV(8989.5,DA,0)=XP1 ;zero node with new pointers
- . ;Get Definition and check if Data Type is pointer, then get pointed to global ref.
- . S PT=$G(^XTV(8989.51,+$P(XP1,U,2),1)) D:$P(PT,U)="P"
- . . S XP3=$G(^XTV(8989.5,DA,1)),PT=$P(PT,U,2)
- . . S:PT $P(XP3,U)=$$FIND1^DIC(PT,"","X",$P(XP3,U)) ;resolve pointer value
- . . S:$P(XP3,U) ^XTV(8989.5,DA,1)=XP3
- . ;X-ref it
- . S DIK="^XTV(8989.5," D IX1^DIK
- Q
- ;
- LKPAR(ENT,PAR,INST) ;Lookup an entry
- Q $O(^XTV(8989.5,"AC",PAR,ENT,INST,0))
- ;
- ADDPAR(ENT,PAR,INST) ;Add a parameter instance
- N FDA,FDAIEN,DIERR
- S FDA(8989.5,"+1,",.01)=ENT
- S FDA(8989.5,"+1,",.02)=PAR
- S FDA(8989.5,"+1,",.03)=INST
- D UPDATE^DIE("","FDA","FDAIEN","DIERR")
- Q
- ;
- PAR1F1 ;PARAMETER File 8989.51: file Pre
- Q
- PAR1E1 ;PARAMETER file 8989.51: entry pre
- N XP1,XP2,XP3
- S ^TMP($J,"XPD",DA)=""
- ;if there is a new Description, kill the old Description
- K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0)) ^XTV(8989.51,DA,20)
- ;Kill any old Allowable entries
- K:$O(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0)) ^XTV(8989.51,DA,30)
- Q
- PAR1F2 ;PARAMETER file 8989.51: file post
- N XPD,DIK,DA
- S DA=0
- F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D
- . S DIK="^XTV(8989.51," D IX1^DIK
- D PAR0F2 ;Go load the entries from 8989.5
- Q
- PAR1DEL(RT) ;Delete Parameter Def entries
- D DELPTR^XPDUTL1(8989.51,RT) ;Cleanup pointers
- D DELIEN^XPDUTL1(8989.51,RT) ;Cleanup entries
- Q
- ;
- PAR2F1 ;PARAMETER File 8989.52: file Pre
- K ^TMP($J,"XPD")
- Q
- PAR2E1 ;PARAMETER file 8989.52: entry Pre
- N XP1,XP2,ROOT
- S ROOT=$NA(^XTMP("XPDI",XPDA,"KRN",8989.52))
- S XP2=$P(@ROOT@(OLDA,0),U,4) ;Use instance of
- ;Because we change the transport global see that a restart will work
- I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2)
- S XP1=0
- F S XP1=$O(@ROOT@(OLDA,10,XP1)),XP2="" Q:'XP1 D
- . S XP2=$P(@ROOT@(OLDA,10,XP1,0),U,2) ;Parameter
- . I $L(XP2),XP2?1A.E S $P(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NA(^XTV(8989.51)),XP2)
- . Q
- Q
- PAR2F2 ;PARAMETER file 8989.52: file Post
- Q
- PAR2DEL(RT) ;Delete Parameter Templates
- D DELIEN^XPDUTL1(8989.52,RT)
- Q
- XPDIA3 ;SFISC/RWF - Install Pre/Post Actions for Kernel files cont. ;6/22/06 09:13
- +1 ;;8.0;KERNEL;**201,302,393,498,1009,1013,1016**;Jul 10, 1995;Build 5
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 QUIT
- +4 ;^XTMP("XPDI",,XPDA,"KRN",XPDFILE,OLDA) is the global root
- +5 ;XPDNM=package name, XPDA=ien in ^XPD(9.6,
- +6 ;DA=ien in file, OLDA= ien in ^XTMP
- +7 ;
- PAR0F2 ;PARAMETER file 8989.5: post. This is a fake entry called from the post of file 8989.51
- +1 ;Now load any entries from 8989.5
- +2 NEW XP1,XP2,XP3,DIK,OLDA,DA,ERR,PN,PE,PT,ROOT
- +3 ;Get the package
- SET XP1=$ORDER(^XTMP("XPDI",XPDA,"PKG",0))
- +4 IF 'XP1
- QUIT
- SET PN=$GET(^XTMP("XPDI",XPDA,"PKG",XP1,0))
- +5 ;Get the IEN of the package
- SET PE=$$FIND1^DIC(9.4,,"MX",$PIECE(PN,U,2))
- +6 SET OLDA=0
- SET ROOT=$NAME(^XTMP("XPDI",XPDA,"KRN",8989.5))
- +7 FOR
- SET OLDA=$ORDER(@ROOT@(OLDA))
- IF 'OLDA
- QUIT
- Begin DoDot:1
- +8 SET XP1=@ROOT@(OLDA,0)
- +9 ;entity
- SET $PIECE(XP1,U,1)=PE_";DIC(9.4,"
- +10 SET $PIECE(XP1,U,2)=$$LK^XPDIA($NAME(^XTV(8989.51)),$PIECE(XP1,U,2))
- +11 SET DA=$$LKPAR($PIECE(XP1,U),$PIECE(XP1,U,2),$PIECE(XP1,U,3))
- +12 ;Remove the current entry if we have one
- +13 IF DA>0
- SET DIK="^XTV(8989.5,"
- DO ^DIK
- +14 ;Otherwise Add the zero node, See that we have a IEN
- +15 IF DA'>0
- DO ADDPAR($PIECE(XP1,U),$PIECE(XP1,U,2),$PIECE(XP1,U,3))
- SET DA=$$LKPAR($PIECE(XP1,U),$PIECE(XP1,U,2),$PIECE(XP1,U,3))
- +16 ;don't have a entry
- IF 'DA
- QUIT
- +17 ;Merge the date ;with IHS fix
- +18 MERGE ^XTV(8989.5,DA)=^XTMP("XPDI",XPDA,"KRN",8989.5,OLDA)
- +19 ;zero node with new pointers
- SET ^XTV(8989.5,DA,0)=XP1
- +20 ;Get Definition and check if Data Type is pointer, then get pointed to global ref.
- +21 SET PT=$GET(^XTV(8989.51,+$PIECE(XP1,U,2),1))
- IF $PIECE(PT,U)="P"
- Begin DoDot:2
- +22 SET XP3=$GET(^XTV(8989.5,DA,1))
- SET PT=$PIECE(PT,U,2)
- +23 ;resolve pointer value
- IF PT
- SET $PIECE(XP3,U)=$$FIND1^DIC(PT,"","X",$PIECE(XP3,U))
- +24 IF $PIECE(XP3,U)
- SET ^XTV(8989.5,DA,1)=XP3
- End DoDot:2
- +25 ;X-ref it
- +26 SET DIK="^XTV(8989.5,"
- DO IX1^DIK
- End DoDot:1
- +27 QUIT
- +28 ;
- LKPAR(ENT,PAR,INST) ;Lookup an entry
- +1 QUIT $ORDER(^XTV(8989.5,"AC",PAR,ENT,INST,0))
- +2 ;
- ADDPAR(ENT,PAR,INST) ;Add a parameter instance
- +1 NEW FDA,FDAIEN,DIERR
- +2 SET FDA(8989.5,"+1,",.01)=ENT
- +3 SET FDA(8989.5,"+1,",.02)=PAR
- +4 SET FDA(8989.5,"+1,",.03)=INST
- +5 DO UPDATE^DIE("","FDA","FDAIEN","DIERR")
- +6 QUIT
- +7 ;
- PAR1F1 ;PARAMETER File 8989.51: file Pre
- +1 QUIT
- PAR1E1 ;PARAMETER file 8989.51: entry pre
- +1 NEW XP1,XP2,XP3
- +2 SET ^TMP($JOB,"XPD",DA)=""
- +3 ;if there is a new Description, kill the old Description
- +4 IF $ORDER(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,20,0))
- KILL ^XTV(8989.51,DA,20)
- +5 ;Kill any old Allowable entries
- +6 IF $ORDER(^XTMP("XPDI",XPDA,"KRN",8989.51,OLDA,30,0))
- KILL ^XTV(8989.51,DA,30)
- +7 QUIT
- PAR1F2 ;PARAMETER file 8989.51: file post
- +1 NEW XPD,DIK,DA
- +2 SET DA=0
- +3 FOR
- SET DA=$ORDER(^TMP($JOB,"XPD",DA))
- IF 'DA
- QUIT
- Begin DoDot:1
- +4 SET DIK="^XTV(8989.51,"
- DO IX1^DIK
- End DoDot:1
- +5 ;Go load the entries from 8989.5
- DO PAR0F2
- +6 QUIT
- PAR1DEL(RT) ;Delete Parameter Def entries
- +1 ;Cleanup pointers
- DO DELPTR^XPDUTL1(8989.51,RT)
- +2 ;Cleanup entries
- DO DELIEN^XPDUTL1(8989.51,RT)
- +3 QUIT
- +4 ;
- PAR2F1 ;PARAMETER File 8989.52: file Pre
- +1 KILL ^TMP($JOB,"XPD")
- +2 QUIT
- PAR2E1 ;PARAMETER file 8989.52: entry Pre
- +1 NEW XP1,XP2,ROOT
- +2 SET ROOT=$NAME(^XTMP("XPDI",XPDA,"KRN",8989.52))
- +3 ;Use instance of
- SET XP2=$PIECE(@ROOT@(OLDA,0),U,4)
- +4 ;Because we change the transport global see that a restart will work
- +5 IF $LENGTH(XP2)
- IF XP2?1A.E
- SET $PIECE(@ROOT@(OLDA,0),U,4)=$$LK^XPDIA($NAME(^XTV(8989.51)),XP2)
- +6 SET XP1=0
- +7 FOR
- SET XP1=$ORDER(@ROOT@(OLDA,10,XP1))
- SET XP2=""
- IF 'XP1
- QUIT
- Begin DoDot:1
- +8 ;Parameter
- SET XP2=$PIECE(@ROOT@(OLDA,10,XP1,0),U,2)
- +9 IF $LENGTH(XP2)
- IF XP2?1A.E
- SET $PIECE(@ROOT@(OLDA,10,XP1,0),U,2)=$$LK^XPDIA($NAME(^XTV(8989.51)),XP2)
- +10 QUIT
- End DoDot:1
- +11 QUIT
- PAR2F2 ;PARAMETER file 8989.52: file Post
- +1 QUIT
- PAR2DEL(RT) ;Delete Parameter Templates
- +1 DO DELIEN^XPDUTL1(8989.52,RT)
- +2 QUIT
