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 ---[H[J[2J[HPRCHSTAT 1264 printed Oct 16, 2024@18:11:30 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
