Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XPDPROT

XPDPROT.m

Go to the documentation of this file.
  1. XPDPROT ;SFISC/RWF,RSD - Manage Protocol Items ;05/24/2010
  1. ;;8.0;KERNEL;**547**;Jul 10, 1995;Build 15
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. Q
  1. ;
  1. ;PARENT=Protocol to add to, CHILD=Protocol to add to PARENT, MNE=Mnemonic (1-4 characters)
  1. ;SEQ=Sequence (number from 1 - 999)
  1. ADD(PARENT,CHILD,MNE,SEQ) ;EF. Add Child to Item multiple of Parent
  1. Q:$G(PARENT)']"" 0 Q:$G(CHILD)']"" 0
  1. N X,XPD1,XPD2,XPD3,DIC,DIE,DA,D0,DR,DLAYGO
  1. S XPD1=$$LKPROT(PARENT) Q:XPD1'>0 "0^parent protocol not found"
  1. ;quit if type is not menu,protocol,protocol menu, limited protocol, or extended action
  1. I "MOQLX"'[$E($$TYPE(XPD1)_"^",1) Q "0^wrong type"
  1. S XPD2=$$LKPROT(CHILD) Q:XPD2'>0 "0^child protocol not found"
  1. ;if protocol is not in ITEM, add it
  1. I '$D(^ORD(101,XPD1,10,"B",XPD2)) D
  1. .S X=XPD2,(D0,DA(1))=XPD1,DIC(0)="MLF",DIC("P")=$P(^DD(101,10,0),"^",2),DLAYGO=101,DIC="^ORD(101,"_XPD1_",10,"
  1. .D FILE^DICN
  1. S XPD3=$O(^ORD(101,XPD1,10,"B",XPD2,0))
  1. I XPD3>0 S DR="" S:$G(MNE)]"" DR="2///"_$G(MNE)_";" S:+$G(SEQ)>0 DR=DR_"3///"_+$G(SEQ) I DR]"" S DIE="^ORD(101,"_XPD1_",10,",DA=XPD3,DA(1)=XPD1 D ^DIE
  1. Q XPD3>0
  1. ;
  1. LKPROT(X) ;EF. To lookup on "B"
  1. Q $O(^ORD(101,"B",X,0))
  1. ;
  1. TYPE(X) ;EF. Return protocol type, Pass IFN.
  1. Q:X'>0 "" Q $P($G(^ORD(101,X,0)),"^",4)
  1. ;
  1. ;PARENT=Protocol to delete from, CHILD=protocol to delete from PARENT
  1. DELETE(PARENT,CHILD) ;EF. Delete entry from ITEM multiple
  1. Q:$G(PARENT)']"" 0 Q:$G(CHILD)']"" 0
  1. N XPD1,XPD2,DIK,DA,X
  1. S XPD1=$$LKPROT(PARENT) Q:XPD1'>0 "0^parent protocol not found"
  1. I "MOQLX"'[$E($$TYPE(XPD1)_"^",1) Q "0^wrong type"
  1. S XPD2=$$LKPROT(CHILD) Q:XPD2'>0 "0^child protocol not found"
  1. S DA=$O(^ORD(101,XPD1,10,"B",XPD2,0)) Q:DA'>0 0
  1. S DA(1)=XPD1,DIK="^ORD(101,XPD1,10," D ^DIK
  1. Q 1
  1. ;
  1. ;PROT=protocol to disable, TXT=message or @ to delete existing value
  1. OUT(PROT,TXT) ;Disable protocol
  1. Q:$G(PROT)']""
  1. N XPD,XPD1
  1. S XPD1=$$LKPROT(PROT) Q:XPD1'>0
  1. S XPD(101,XPD1_",",2)=$G(TXT) D FILE^DIE("","XPD")
  1. Q
  1. ;
  1. ;OLD=old name, NEW=new name
  1. RENAME(OLD,NEW) ;Rename protocol
  1. Q:$G(OLD)']"" Q:$G(NEW)']""
  1. N XPD,XPD1
  1. S XPD1=$$LKPROT(OLD) Q:XPD1'>0
  1. S XPD(101,XPD1_",",.01)=NEW D FILE^DIE("","XPD")
  1. Q
  1. FIND(RESULT,PROT) ;Find all parents for PROT
  1. ; Input: RESULT - Results array name, passed by reference (req)
  1. ; PROT - name of protocol (req)
  1. ; Output: RESULT(0)= number of parents found
  1. ; OR
  1. ; -1 ^ error message
  1. ;RESULT(FILE 101 ien)= parent protocol name (FILE 101, Field .01)
  1. ;
  1. I $G(PROT)']"" S RESULT(0)="-1^protocol not defined" Q
  1. N XPD1,XPDCNT,XPDIEN
  1. S XPD1=$$LKPROT(PROT)
  1. I XPD1'>0 S RESULT(0)="-1^protocol not found" Q
  1. S (XPDCNT,XPDIEN)=0
  1. F S XPDIEN=$O(^ORD(101,"AD",XPD1,XPDIEN)) Q:'XPDIEN D
  1. .S RESULT(XPDIEN)=$P($G(^ORD(101,XPDIEN,0)),U,1),XPDCNT=XPDCNT+1
  1. S RESULT(0)=XPDCNT
  1. Q