PRCHSTAT.m

PRCHSTAT ;WISC/TGH-UTILITY PROGRAM FOR UPDATING SUPPLY STATUS ON 442 ;10/30/92  1:58 PM ;10/30/92  1:57 PM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

ENXS ;SET LOGIC-MUMPS CROSS-REFERENCE ON SUPPLY STATUS (FIELD .5) FILE 442

 Q:'$D(^PRCD(442.3,+X,0))  S PRCHZ1=$P(^(0),U,2),PRCHZ2=$P(^(0),U,3)

 I PRCHZ1 S $P(^PRC(442,DA,7),U,2)=PRCHZ1,^PRC(442,"AH",PRCHZ1,DA)=""

 I PRCHZ2 S $P(^PRC(442,DA,7),U,4)=PRCHZ2,^PRC(442,"AI",PRCHZ2,DA)=""

 K PRCHZ1,PRCHZ2 Q

ENXK ;KILL LOGIC-MUMPS CROSS-REFERENCE ON SUPPLY STATUS (FIELD .5) FILE 442

 Q:'$D(^PRCD(442.3,+X,0))  S PRCHZ1=$P(^(0),U,2),PRCHZ2=$P(^(0),U,3)

 I PRCHZ1 S $P(^PRC(442,DA,7),U,2)="" K ^PRC(442,"AH",PRCHZ1,DA)

 I PRCHZ2 S $P(^PRC(442,DA,7),U,4)="" K ^PRC(442,"AI",PRCHZ2,DA)

 K PRCHZ1,PRCHZ2 Q

ENF ;X=FISCAL STATUS ORDER, DA=INTERNAL RECORD NO. ON 442

 NEW Y S Y=$O(^PRCD(442.3,"AC",+X,0)) G UPD

ENS ;X=SUPPLY STATUS ORDER, DA=INTERNAL RECORD NO. ON 442

 NEW Y S Y=$O(^PRCD(442.3,"C",+X,0)) G UPD

UPD ;UPDATE SUPPLY STATUS, SUPPLY STATUS ORDER & FISCAL STATUS ORDER ON FILE 442

 G:'Y ERR G:'$D(^PRCD(442.3,Y,0)) ERR

 NEW DIE,DR,PRCHX S PRCHX=X,X=Y,DIE="^PRC(442,",DR=".5////"_Y D ^DIE K DIE,DR S X=PRCHX

EXIT K PRCHX,Y Q

ERR K X G EXIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHSTAT   1264     printed  Apr 09, 2024@21:06:50                                                                                                                                                                                                    Page 2

PRCHSTAT  ;WISC/TGH-UTILITY PROGRAM FOR UPDATING SUPPLY STATUS ON 442 ;10/30/92  1:58 PM ;10/30/92  1:57 PM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

ENXS      ;SET LOGIC-MUMPS CROSS-REFERENCE ON SUPPLY STATUS (FIELD .5) FILE 442

 +1        if '$DATA(^PRCD(442.3,+X,0))

               QUIT 

           SET PRCHZ1=$PIECE(^(0),U,2)

           SET PRCHZ2=$PIECE(^(0),U,3)

 +2        IF PRCHZ1

               SET $PIECE(^PRC(442,DA,7),U,2)=PRCHZ1

               SET ^PRC(442,"AH",PRCHZ1,DA)=""

 +3        IF PRCHZ2

               SET $PIECE(^PRC(442,DA,7),U,4)=PRCHZ2

               SET ^PRC(442,"AI",PRCHZ2,DA)=""

 +4        KILL PRCHZ1,PRCHZ2

           QUIT 

ENXK      ;KILL LOGIC-MUMPS CROSS-REFERENCE ON SUPPLY STATUS (FIELD .5) FILE 442

 +1        if '$DATA(^PRCD(442.3,+X,0))

               QUIT 

           SET PRCHZ1=$PIECE(^(0),U,2)

           SET PRCHZ2=$PIECE(^(0),U,3)

 +2        IF PRCHZ1

               SET $PIECE(^PRC(442,DA,7),U,2)=""

               KILL ^PRC(442,"AH",PRCHZ1,DA)

 +3        IF PRCHZ2

               SET $PIECE(^PRC(442,DA,7),U,4)=""

               KILL ^PRC(442,"AI",PRCHZ2,DA)

 +4        KILL PRCHZ1,PRCHZ2

           QUIT 

ENF       ;X=FISCAL STATUS ORDER, DA=INTERNAL RECORD NO. ON 442

 +1        NEW Y

           SET Y=$ORDER(^PRCD(442.3,"AC",+X,0))

           GOTO UPD

ENS       ;X=SUPPLY STATUS ORDER, DA=INTERNAL RECORD NO. ON 442

 +1        NEW Y

           SET Y=$ORDER(^PRCD(442.3,"C",+X,0))

           GOTO UPD

UPD       ;UPDATE SUPPLY STATUS, SUPPLY STATUS ORDER & FISCAL STATUS ORDER ON FILE 442

 +1        if 'Y

               GOTO ERR

           if '$DATA(^PRCD(442.3,Y,0))

               GOTO ERR

 +2        NEW DIE,DR,PRCHX

           SET PRCHX=X

           SET X=Y

           SET DIE="^PRC(442,"

           SET DR=".5////"_Y

           DO ^DIE

           KILL DIE,DR

           SET X=PRCHX

EXIT       KILL PRCHX,Y

           QUIT 

ERR        KILL X

           GOTO EXIT