- 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 Feb 18, 2025@23:39:12 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
