- XPDPROT ;SFISC/RWF,RSD - Manage Protocol Items ;05/24/2010
- ;;8.0;KERNEL;**547**;Jul 10, 1995;Build 15
- ;Per VHA Directive 2004-038, this routine should not be modified.
- Q
- ;
- ;PARENT=Protocol to add to, CHILD=Protocol to add to PARENT, MNE=Mnemonic (1-4 characters)
- ;SEQ=Sequence (number from 1 - 999)
- ADD(PARENT,CHILD,MNE,SEQ) ;EF. Add Child to Item multiple of Parent
- Q:$G(PARENT)']"" 0 Q:$G(CHILD)']"" 0
- N X,XPD1,XPD2,XPD3,DIC,DIE,DA,D0,DR,DLAYGO
- S XPD1=$$LKPROT(PARENT) Q:XPD1'>0 "0^parent protocol not found"
- ;quit if type is not menu,protocol,protocol menu, limited protocol, or extended action
- I "MOQLX"'[$E($$TYPE(XPD1)_"^",1) Q "0^wrong type"
- S XPD2=$$LKPROT(CHILD) Q:XPD2'>0 "0^child protocol not found"
- ;if protocol is not in ITEM, add it
- I '$D(^ORD(101,XPD1,10,"B",XPD2)) D
- .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,"
- .D FILE^DICN
- S XPD3=$O(^ORD(101,XPD1,10,"B",XPD2,0))
- 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
- Q XPD3>0
- ;
- LKPROT(X) ;EF. To lookup on "B"
- Q $O(^ORD(101,"B",X,0))
- ;
- TYPE(X) ;EF. Return protocol type, Pass IFN.
- Q:X'>0 "" Q $P($G(^ORD(101,X,0)),"^",4)
- ;
- ;PARENT=Protocol to delete from, CHILD=protocol to delete from PARENT
- DELETE(PARENT,CHILD) ;EF. Delete entry from ITEM multiple
- Q:$G(PARENT)']"" 0 Q:$G(CHILD)']"" 0
- N XPD1,XPD2,DIK,DA,X
- S XPD1=$$LKPROT(PARENT) Q:XPD1'>0 "0^parent protocol not found"
- I "MOQLX"'[$E($$TYPE(XPD1)_"^",1) Q "0^wrong type"
- S XPD2=$$LKPROT(CHILD) Q:XPD2'>0 "0^child protocol not found"
- S DA=$O(^ORD(101,XPD1,10,"B",XPD2,0)) Q:DA'>0 0
- S DA(1)=XPD1,DIK="^ORD(101,XPD1,10," D ^DIK
- Q 1
- ;
- ;PROT=protocol to disable, TXT=message or @ to delete existing value
- OUT(PROT,TXT) ;Disable protocol
- Q:$G(PROT)']""
- N XPD,XPD1
- S XPD1=$$LKPROT(PROT) Q:XPD1'>0
- S XPD(101,XPD1_",",2)=$G(TXT) D FILE^DIE("","XPD")
- Q
- ;
- ;OLD=old name, NEW=new name
- RENAME(OLD,NEW) ;Rename protocol
- Q:$G(OLD)']"" Q:$G(NEW)']""
- N XPD,XPD1
- S XPD1=$$LKPROT(OLD) Q:XPD1'>0
- S XPD(101,XPD1_",",.01)=NEW D FILE^DIE("","XPD")
- Q
- FIND(RESULT,PROT) ;Find all parents for PROT
- ; Input: RESULT - Results array name, passed by reference (req)
- ; PROT - name of protocol (req)
- ; Output: RESULT(0)= number of parents found
- ; OR
- ; -1 ^ error message
- ;RESULT(FILE 101 ien)= parent protocol name (FILE 101, Field .01)
- ;
- I $G(PROT)']"" S RESULT(0)="-1^protocol not defined" Q
- N XPD1,XPDCNT,XPDIEN
- S XPD1=$$LKPROT(PROT)
- I XPD1'>0 S RESULT(0)="-1^protocol not found" Q
- S (XPDCNT,XPDIEN)=0
- F S XPDIEN=$O(^ORD(101,"AD",XPD1,XPDIEN)) Q:'XPDIEN D
- .S RESULT(XPDIEN)=$P($G(^ORD(101,XPDIEN,0)),U,1),XPDCNT=XPDCNT+1
- S RESULT(0)=XPDCNT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDPROT 2893 printed Jan 18, 2025@03:05:38 Page 2
- XPDPROT ;SFISC/RWF,RSD - Manage Protocol Items ;05/24/2010
- +1 ;;8.0;KERNEL;**547**;Jul 10, 1995;Build 15
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;PARENT=Protocol to add to, CHILD=Protocol to add to PARENT, MNE=Mnemonic (1-4 characters)
- +6 ;SEQ=Sequence (number from 1 - 999)
- ADD(PARENT,CHILD,MNE,SEQ) ;EF. Add Child to Item multiple of Parent
- +1 if $GET(PARENT)']""
- QUIT 0
- if $GET(CHILD)']""
- QUIT 0
- +2 NEW X,XPD1,XPD2,XPD3,DIC,DIE,DA,D0,DR,DLAYGO
- +3 SET XPD1=$$LKPROT(PARENT)
- if XPD1'>0
- QUIT "0^parent protocol not found"
- +4 ;quit if type is not menu,protocol,protocol menu, limited protocol, or extended action
- +5 IF "MOQLX"'[$EXTRACT($$TYPE(XPD1)_"^",1)
- QUIT "0^wrong type"
- +6 SET XPD2=$$LKPROT(CHILD)
- if XPD2'>0
- QUIT "0^child protocol not found"
- +7 ;if protocol is not in ITEM, add it
- +8 IF '$DATA(^ORD(101,XPD1,10,"B",XPD2))
- Begin DoDot:1
- +9 SET X=XPD2
- SET (D0,DA(1))=XPD1
- SET DIC(0)="MLF"
- SET DIC("P")=$PIECE(^DD(101,10,0),"^",2)
- SET DLAYGO=101
- SET DIC="^ORD(101,"_XPD1_",10,"
- +10 DO FILE^DICN
- End DoDot:1
- +11 SET XPD3=$ORDER(^ORD(101,XPD1,10,"B",XPD2,0))
- +12 IF XPD3>0
- SET DR=""
- if $GET(MNE)]""
- SET DR="2///"_$GET(MNE)_";"
- if +$GET(SEQ)>0
- SET DR=DR_"3///"_+$GET(SEQ)
- IF DR]""
- SET DIE="^ORD(101,"_XPD1_",10,"
- SET DA=XPD3
- SET DA(1)=XPD1
- DO ^DIE
- +13 QUIT XPD3>0
- +14 ;
- LKPROT(X) ;EF. To lookup on "B"
- +1 QUIT $ORDER(^ORD(101,"B",X,0))
- +2 ;
- TYPE(X) ;EF. Return protocol type, Pass IFN.
- +1 if X'>0
- QUIT ""
- QUIT $PIECE($GET(^ORD(101,X,0)),"^",4)
- +2 ;
- +3 ;PARENT=Protocol to delete from, CHILD=protocol to delete from PARENT
- DELETE(PARENT,CHILD) ;EF. Delete entry from ITEM multiple
- +1 if $GET(PARENT)']""
- QUIT 0
- if $GET(CHILD)']""
- QUIT 0
- +2 NEW XPD1,XPD2,DIK,DA,X
- +3 SET XPD1=$$LKPROT(PARENT)
- if XPD1'>0
- QUIT "0^parent protocol not found"
- +4 IF "MOQLX"'[$EXTRACT($$TYPE(XPD1)_"^",1)
- QUIT "0^wrong type"
- +5 SET XPD2=$$LKPROT(CHILD)
- if XPD2'>0
- QUIT "0^child protocol not found"
- +6 SET DA=$ORDER(^ORD(101,XPD1,10,"B",XPD2,0))
- if DA'>0
- QUIT 0
- +7 SET DA(1)=XPD1
- SET DIK="^ORD(101,XPD1,10,"
- DO ^DIK
- +8 QUIT 1
- +9 ;
- +10 ;PROT=protocol to disable, TXT=message or @ to delete existing value
- OUT(PROT,TXT) ;Disable protocol
- +1 if $GET(PROT)']""
- QUIT
- +2 NEW XPD,XPD1
- +3 SET XPD1=$$LKPROT(PROT)
- if XPD1'>0
- QUIT
- +4 SET XPD(101,XPD1_",",2)=$GET(TXT)
- DO FILE^DIE("","XPD")
- +5 QUIT
- +6 ;
- +7 ;OLD=old name, NEW=new name
- RENAME(OLD,NEW) ;Rename protocol
- +1 if $GET(OLD)']""
- QUIT
- if $GET(NEW)']""
- QUIT
- +2 NEW XPD,XPD1
- +3 SET XPD1=$$LKPROT(OLD)
- if XPD1'>0
- QUIT
- +4 SET XPD(101,XPD1_",",.01)=NEW
- DO FILE^DIE("","XPD")
- +5 QUIT
- FIND(RESULT,PROT) ;Find all parents for PROT
- +1 ; Input: RESULT - Results array name, passed by reference (req)
- +2 ; PROT - name of protocol (req)
- +3 ; Output: RESULT(0)= number of parents found
- +4 ; OR
- +5 ; -1 ^ error message
- +6 ;RESULT(FILE 101 ien)= parent protocol name (FILE 101, Field .01)
- +7 ;
- +8 IF $GET(PROT)']""
- SET RESULT(0)="-1^protocol not defined"
- QUIT
- +9 NEW XPD1,XPDCNT,XPDIEN
- +10 SET XPD1=$$LKPROT(PROT)
- +11 IF XPD1'>0
- SET RESULT(0)="-1^protocol not found"
- QUIT
- +12 SET (XPDCNT,XPDIEN)=0
- +13 FOR
- SET XPDIEN=$ORDER(^ORD(101,"AD",XPD1,XPDIEN))
- if 'XPDIEN
- QUIT
- Begin DoDot:1
- +14 SET RESULT(XPDIEN)=$PIECE($GET(^ORD(101,XPDIEN,0)),U,1)
- SET XPDCNT=XPDCNT+1
- End DoDot:1
- +15 SET RESULT(0)=XPDCNT
- +16 QUIT