PRCPAWAP ;WISC/RFJ-adjustment approval ;11 Mar 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$D(PRCP("I"))
I PRCP("DPTYPE")'="W" W !,"ONLY THE WAREHOUSE CAN USE THIS OPTION." Q
S IOP="HOME" D ^%ZIS K IOP
;
N %,%DT,%H,%I,D,D0,DA,DATA,DI,DIC,DQ,DR,ITEMDA,NOW,NOWDT,PRCPFLAG,TRANID,UNAPPR,X,Y
ADJ ; get adjustment number, quit if no adjustment is selected.
K PRCPFLAG
S TRANID=$$ADJUSTNO I TRANID["^" Q
;
; get a list of unapproved adjustments and store in tmp global.
K ^TMP($J,"PRCPAWAP")
S (DA,UNAPPR)=0
F S DA=$O(^PRCP(445.2,"T",PRCP("I"),TRANID,DA)) Q:'DA S DATA=$G(^PRCP(445.2,DA,0)) I $P(DATA,"^",5) D
. S ^TMP($J,"PRCPAWAP","ITEM",$P(DATA,"^",5))=DA
. S:'$P(DATA,"^",20) UNAPPR=UNAPPR+1,^TMP($J,"PRCPAWAP","UNAPPR",$P(DATA,"^",5),DA)=""
W !!?10,">> THERE IS '",UNAPPR,"' UNAPPROVED ITEMS ON THIS ADJUSTMENT. <<"
;
; approve **all** items for the selected adjustment.
D NOW^%DTC S (Y,NOWDT)=% D DD^%DT S NOW=Y
I UNAPPR D I $D(PRCPFLAG) K ^TMP($J,"PRCPAWAP") G ADJ
. S XP=" DO YOU WANT TO APPROVE ALL OF THE ITEMS ON THIS ADJUSTMENT",XH=" ENTER 'YES' TO APPROVE ALL THE ITEMS ON THE ADJUSTMENT, 'NO' TO SELECT ITEMS."
. W ! S %=$$YN^PRCPUYN(2)
. I %=2 Q
. I %'=1 S PRCPFLAG=1 Q
. W !!?10,"approving adjustment items"
. S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPAWAP","UNAPPR",ITEMDA)) Q:'ITEMDA S DA=0 F S DA=$O(^TMP($J,"PRCPAWAP","UNAPPR",ITEMDA,DA)) Q:'DA I $D(^PRCP(445.2,DA,0)) D
. . L +^PRCP(445.2,DA)
. . S DATA=^PRCP(445.2,DA,0) I $P(DATA,"^",20)="" W "." S $P(DATA,"^",20)=NOWDT,$P(DATA,"^",21)=DUZ,^(0)=DATA
. . L -^PRCP(445.2,DA)
. W !!?10,">> ALL ITEMS ON ADJUSTMENT HAVE BEEN APPROVED. <<"
. S PRCPFLAG=1
;
ITEM ; aprrove items as selected. only selection of items from the
; selected adjustment number. quit if no item is selected.
W ! S ITEMDA=$$ITEM^PRCPAWU0 I ITEMDA["^" K ^TMP($J,"PRCPAWAP") G ADJ
S DA=^TMP($J,"PRCPAWAP","ITEM",ITEMDA)
L +^PRCP(445.2,DA)
S DATA=^PRCP(445.2,DA,0),DR="20 ADJUSTMENT APPROVAL" I $P(DATA,"^",20)="" S DR=DR_"//"_NOW
E W !!?10,">> ITEM ADJUSTMENT HAS ALREADY BEEN APPROVED, '@' FOR UNAPPROVED. <<"
S DIE="^PRCP(445.2," D ^DIE K DIE
S DATA=^PRCP(445.2,DA,0) I $P(DATA,"^",20),'$P(DATA,"^",21) S $P(^(0),"^",21)=DUZ,$P(DATA,"^",6)=DUZ
I '$P(DATA,"^",20),$P(DATA,"^",21) S $P(^PRCP(445.2,DA,0),"^",21)=""
L -^PRCP(445.2,DA)
G ITEM
;
;
ADJUSTNO() ; return selected adjustment number from file 445.2.
N %,ADJNO,COUNT,PRCPFLAG,X
F D Q:ADJNO'=""
. W !!,"Select ADJUSTMENT NUMBER: "
. R X:DTIME I '$T!(X["^")!(X="") S ADJNO="^" Q
. S:$E(X) X="A"_X
. I $E(X)="A",$D(^PRCP(445.2,"T",PRCP("I"),X)) S ADJNO=X Q
. S ADJNO=""
. W !,"Select the ADJUSTMENT NUMBER from the list below:",!
. S COUNT=0,X="A" F S X=$O(^PRCP(445.2,"T",PRCP("I"),X)) Q:$E(X)'="A"!($G(PRCPFLAG)) D
. . W " ADJUSTMENT NUMBER: ",X S COUNT=COUNT+1
. . I COUNT#20=0 D P^PRCPUREP S %="",$P(%," ",80)="" W $C(13),%
. . W !
Q ADJNO
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWAP 3130 printed Dec 13, 2024@02:12:49 Page 2
PRCPAWAP ;WISC/RFJ-adjustment approval ;11 Mar 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$DATA(PRCP("I"))
QUIT
+4 IF PRCP("DPTYPE")'="W"
WRITE !,"ONLY THE WAREHOUSE CAN USE THIS OPTION."
QUIT
+5 SET IOP="HOME"
DO ^%ZIS
KILL IOP
+6 ;
+7 NEW %,%DT,%H,%I,D,D0,DA,DATA,DI,DIC,DQ,DR,ITEMDA,NOW,NOWDT,PRCPFLAG,TRANID,UNAPPR,X,Y
ADJ ; get adjustment number, quit if no adjustment is selected.
+1 KILL PRCPFLAG
+2 SET TRANID=$$ADJUSTNO
IF TRANID["^"
QUIT
+3 ;
+4 ; get a list of unapproved adjustments and store in tmp global.
+5 KILL ^TMP($JOB,"PRCPAWAP")
+6 SET (DA,UNAPPR)=0
+7 FOR
SET DA=$ORDER(^PRCP(445.2,"T",PRCP("I"),TRANID,DA))
if 'DA
QUIT
SET DATA=$GET(^PRCP(445.2,DA,0))
IF $PIECE(DATA,"^",5)
Begin DoDot:1
+8 SET ^TMP($JOB,"PRCPAWAP","ITEM",$PIECE(DATA,"^",5))=DA
+9 if '$PIECE(DATA,"^",20)
SET UNAPPR=UNAPPR+1
SET ^TMP($JOB,"PRCPAWAP","UNAPPR",$PIECE(DATA,"^",5),DA)=""
End DoDot:1
+10 WRITE !!?10,">> THERE IS '",UNAPPR,"' UNAPPROVED ITEMS ON THIS ADJUSTMENT. <<"
+11 ;
+12 ; approve **all** items for the selected adjustment.
+13 DO NOW^%DTC
SET (Y,NOWDT)=%
DO DD^%DT
SET NOW=Y
+14 IF UNAPPR
Begin DoDot:1
+15 SET XP=" DO YOU WANT TO APPROVE ALL OF THE ITEMS ON THIS ADJUSTMENT"
SET XH=" ENTER 'YES' TO APPROVE ALL THE ITEMS ON THE ADJUSTMENT, 'NO' TO SELECT ITEMS."
+16 WRITE !
SET %=$$YN^PRCPUYN(2)
+17 IF %=2
QUIT
+18 IF %'=1
SET PRCPFLAG=1
QUIT
+19 WRITE !!?10,"approving adjustment items"
+20 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPAWAP","UNAPPR",ITEMDA))
if 'ITEMDA
QUIT
SET DA=0
FOR
SET DA=$ORDER(^TMP($JOB,"PRCPAWAP","UNAPPR",ITEMDA,DA))
if 'DA
QUIT
IF $DATA(^PRCP(445.2,DA,0))
Begin DoDot:2
+21 LOCK +^PRCP(445.2,DA)
+22 SET DATA=^PRCP(445.2,DA,0)
IF $PIECE(DATA,"^",20)=""
WRITE "."
SET $PIECE(DATA,"^",20)=NOWDT
SET $PIECE(DATA,"^",21)=DUZ
SET ^(0)=DATA
+23 LOCK -^PRCP(445.2,DA)
End DoDot:2
+24 WRITE !!?10,">> ALL ITEMS ON ADJUSTMENT HAVE BEEN APPROVED. <<"
+25 SET PRCPFLAG=1
End DoDot:1
IF $DATA(PRCPFLAG)
KILL ^TMP($JOB,"PRCPAWAP")
GOTO ADJ
+26 ;
ITEM ; aprrove items as selected. only selection of items from the
+1 ; selected adjustment number. quit if no item is selected.
+2 WRITE !
SET ITEMDA=$$ITEM^PRCPAWU0
IF ITEMDA["^"
KILL ^TMP($JOB,"PRCPAWAP")
GOTO ADJ
+3 SET DA=^TMP($JOB,"PRCPAWAP","ITEM",ITEMDA)
+4 LOCK +^PRCP(445.2,DA)
+5 SET DATA=^PRCP(445.2,DA,0)
SET DR="20 ADJUSTMENT APPROVAL"
IF $PIECE(DATA,"^",20)=""
SET DR=DR_"//"_NOW
+6 IF '$TEST
WRITE !!?10,">> ITEM ADJUSTMENT HAS ALREADY BEEN APPROVED, '@' FOR UNAPPROVED. <<"
+7 SET DIE="^PRCP(445.2,"
DO ^DIE
KILL DIE
+8 SET DATA=^PRCP(445.2,DA,0)
IF $PIECE(DATA,"^",20)
IF '$PIECE(DATA,"^",21)
SET $PIECE(^(0),"^",21)=DUZ
SET $PIECE(DATA,"^",6)=DUZ
+9 IF '$PIECE(DATA,"^",20)
IF $PIECE(DATA,"^",21)
SET $PIECE(^PRCP(445.2,DA,0),"^",21)=""
+10 LOCK -^PRCP(445.2,DA)
+11 GOTO ITEM
+12 ;
+13 ;
ADJUSTNO() ; return selected adjustment number from file 445.2.
+1 NEW %,ADJNO,COUNT,PRCPFLAG,X
+2 FOR
Begin DoDot:1
+3 WRITE !!,"Select ADJUSTMENT NUMBER: "
+4 READ X:DTIME
IF '$TEST!(X["^")!(X="")
SET ADJNO="^"
QUIT
+5 if $EXTRACT(X)
SET X="A"_X
+6 IF $EXTRACT(X)="A"
IF $DATA(^PRCP(445.2,"T",PRCP("I"),X))
SET ADJNO=X
QUIT
+7 SET ADJNO=""
+8 WRITE !,"Select the ADJUSTMENT NUMBER from the list below:",!
+9 SET COUNT=0
SET X="A"
FOR
SET X=$ORDER(^PRCP(445.2,"T",PRCP("I"),X))
if $EXTRACT(X)'="A"!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+10 WRITE " ADJUSTMENT NUMBER: ",X
SET COUNT=COUNT+1
+11 IF COUNT#20=0
DO P^PRCPUREP
SET %=""
SET $PIECE(%," ",80)=""
WRITE $CHAR(13),%
+12 WRITE !
End DoDot:2
End DoDot:1
if ADJNO'=""
QUIT
+13 QUIT ADJNO
