PRCOT07.m

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 ---PRCOT07   778     printed  Apr 09, 2024@21:12:18                                                                                                                                                                                                      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