- 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 Apr 23, 2025@18:26:48 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
