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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOT07 778 printed Nov 22, 2024@17:22:23 Page 2
PRCOT07 ;SF/SWS-PREINSTALL *ADD NEW OPTION ;4-26-94/3:45 PM
V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 QUIT
FINDREC NEW DIC,Y,NREC,MREC,DIE,X
+1 DO BMES^XPDUTL("Adding new option to APPROVING OFFICIAL MENU.")
+2 SET DIC="^DIC(19,"
SET X="PRCH AO CANCEL INCOM PC ORDER"
+3 DO ^DIC
+4 IF Y'=-1
SET NREC=+Y
FINDMNU SET (DIC,Y)=""
+1 SET DIC="^DIC(19,"
SET X="PRCH APPROVE"
+2 DO ^DIC
+3 IF Y'=-1
SET MREC=+Y
UPDMNU SET (DIC,Y)=""
+1 SET (BFLAG,NTHIS)=0
+2 FOR
SET NTHIS=$ORDER(^DIC(19,MREC,10,NTHIS))
if 'NTHIS!(BFLAG=1)
QUIT
Begin DoDot:1
+3 SET MYIEN=$GET(^DIC(19,MREC,10,NTHIS,0))
+4 IF MYIEN=NREC
SET BFLAG=1
End DoDot:1
+5 IF BFLAG=0
Begin DoDot:1
+6 SET DIC="^DIC(19,"_MREC_",10,"
SET DIC(0)=""
SET DIC("P")="19.01IP"
+7 SET X=NREC
+8 SET DA(1)=MREC
+9 DO FILE^DICN
End DoDot:1
CLNREC KILL BFLAG,NTHIS,MREC,NREC
+1 QUIT
