PRCOT07 ;SF/SWS-PREINSTALL *ADD NEW OPTION ;4-26-94/3:45 PM
V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4
 ;Per VHA Directive 2004-038, this routine should not be modified.
 Q
FINDREC N DIC,Y,NREC,MREC,DIE,X
 D BMES^XPDUTL("Adding new option to APPROVING OFFICIAL MENU.")
 S DIC="^DIC(19,",X="PRCH AO CANCEL INCOM PC ORDER"
 D ^DIC
 I Y'=-1  S NREC=+Y
FINDMNU S (DIC,Y)=""
 S DIC="^DIC(19,",X="PRCH APPROVE"
 D ^DIC
 I Y'=-1  S MREC=+Y
UPDMNU S (DIC,Y)=""
 S (BFLAG,NTHIS)=0
 F  S NTHIS=$O(^DIC(19,MREC,10,NTHIS))  Q:'NTHIS!(BFLAG=1)  D
 . S MYIEN=$G(^DIC(19,MREC,10,NTHIS,0))
 . I MYIEN=NREC  S BFLAG=1
 I BFLAG=0  D
 . S DIC="^DIC(19,"_MREC_",10,",DIC(0)="",DIC("P")="19.01IP"
 . S X=NREC
 . S DA(1)=MREC
 . D FILE^DICN
CLNREC K BFLAG,NTHIS,MREC,NREC
 Q