PRCPURS0 ;WISC/RFJ-ask sort, select acct, select nsn, select item ;17 May 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
SORTBY() ; select type of sort
N DIR,X,Y
S DIR(0)="S^1:ACCOUNT CODE;2:NSN",DIR("A")="Sort BY",DIR("B")="ACCOUNT CODE" D ^DIR K DIR I Y'=1,Y'=2 Q 0
Q +Y
;
;
SUMMARY() ; print summary only
N %,X
K X S X(1)="Display Summary or ALL Data." D DISPLAY^PRCPUX2(2,40,.X)
S XP="Do you want to print a summary only",XH="Enter 'YES' to print a summary, 'NO' to print entire report, '^' to exit."
S %=$$YN^PRCPUYN(1)
Q $S(%=1:1,%=2:0,1:-1)
;
;
ACCTSEL ; pick account codes or all
; returns array of accounts selected
N %,A,DIR,DIRUT,DTOUT,DUOUT,PRCPEXIT,PRCPFLAG,PRCPLINE,X,Y
S PRCPLINE="",$P(PRCPLINE,"-",78)=""
K ACCOUNT
F %=1,2,3,6,8 S ACCOUNT("NO",%)=""
F D I $G(PRCPFLAG) Q
. W !
. I $O(ACCOUNT("YES",0)) D
. . W !?2,PRCPLINE,!?2,"| Currently selected account codes : "
. . S A=0 F S A=$O(ACCOUNT("YES",A)) Q:'A W A W:$O(ACCOUNT("YES",A)) ", "
. . W ?78,"|",!?2,"| You can DE-select one of the above account codes by reselecting it.",?78,"|"
. I $O(ACCOUNT("NO",0)) D
. . W !?2,PRCPLINE,!?2,"| Currently DE-selected account codes: "
. . S A=0 F S A=$O(ACCOUNT("NO",A)) Q:'A W A W:$O(ACCOUNT("NO",A)) ", "
. . W ?78,"|",!?2,"| You can RE-select one of the above account codes by reselecting it.",?78,"|"
. W !?2,PRCPLINE
. S DIR(0)="SBO^1:Account Code 1;2:Account Code 2;3:Account Code 3;6:Account Code 6;8:Account Code 8;",DIR("A")="Select ACCOUNT Code" D ^DIR I $D(DTOUT)!($D(DUOUT)) S (PRCPFLAG,PRCPEXIT)=1 Q
. S Y=+Y
. I Y=0,'$O(ACCOUNT("YES",0)) D I %=0 S (PRCPFLAG,PRCPEXIT)=1 Q
. . S %=$$ALLACCT I %=0 Q
. . I %=1 K ACCOUNT("NO") F %=1,2,3,6,8 S ACCOUNT("YES",%)=""
. I Y=0 S PRCPFLAG=1 Q
. I $D(ACCOUNT("YES",Y)) K ACCOUNT("YES",Y) S ACCOUNT("NO",Y)="" W !?10,"DE-selected !" Q
. I $D(ACCOUNT("NO",Y)) K ACCOUNT("NO",Y) S ACCOUNT("YES",Y)="" W !?10,"RE-selected !" Q
. S ACCOUNT("YES",Y)="" W !?10,"selected !"
I $G(PRCPEXIT) K ACCOUNT
K ACCOUNT("NO")
W !!,"*** Selected Account Codes: " I '$O(ACCOUNT("YES",0)) W "<<NONE>>" Q
S A=0 F S A=$O(ACCOUNT("YES",A)) Q:'A W A W:$O(ACCOUNT("YES",A)) ", " S ACCOUNT(A)=""
K ACCOUNT("YES")
Q
;
ALLACCT() ; select all account codes
; returns 1 for yes, 2 for no, 0 for ^
S XP="Do you want to select ALL account codes",XH="Enter 'YES' to select all account codes, 'NO' to not select all account codes."
W !
Q $$YN^PRCPUYN(1)
;
;
NSNSEL ; start with and end with nsn
; returns prcpstrt and prcpend
N PRCPFLAG,X
K PRCPSTRT,PRCPEND
F D Q:$G(PRCPFLAG)
. W !,"START with NSN: FIRST// " R X:DTIME I '$T!(X["^") S PRCPFLAG=1 Q
. I X["?" W !?2,"Select the starting NSN value. If you select the default FIRST entry, NULL",!?2,"NSN entries will be selected. If you select 6505, all NSNs starting with",!?2,"6505 will be selected." Q
. I X'="",'$$NSNCHECK(X) W !?5,"Invalid NSN format. Format should be in the form 6505-22-333-4444." Q
. S PRCPSTRT=X,PRCPFLAG=1
I '$D(PRCPSTRT) Q
K PRCPFLAG
F D Q:$G(PRCPFLAG)
. W !," END with NSN: LAST// " R X:DTIME I '$T!(X["^") S PRCPFLAG=1 Q
. I X=" " S X=PRCPSTRT W " ",X
. I X["?" D Q
. . W !?2,"Select the ending NSN value."
. . I PRCPSTRT="" Q
. . W " If you start with ",PRCPSTRT," and end with ",PRCPSTRT,",",!?2,"you will only select NSNs which begin with ",PRCPSTRT,"."
. . W !," Also, enter the <space bar> to set the ending NSN equal to the starting NSN."
. I X'="",'$$NSNCHECK(X) W !?5,"Invalid NSN format. Format should be in the form 6505-22-333-4444." Q
. I X="" S X="z"
. I PRCPSTRT]X W !?4,"Ending NSN must follow starting NSN." Q
. S PRCPEND=X,PRCPFLAG=1
I '$D(PRCPEND) K PRCPSTRT Q
Q
;
NSNCHECK(V1) ; nsn format check
I V1?4N Q 1
I V1?4N1"-"2UN Q 1
I V1?4N1"-"2UN1"-"3N Q 1
I V1?4N1"-"2UN1"-"3N1"-"4N.A Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPURS0 4079 printed Sep 15, 2024@21:40:24 Page 2
PRCPURS0 ;WISC/RFJ-ask sort, select acct, select nsn, select item ;17 May 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
SORTBY() ; select type of sort
+1 NEW DIR,X,Y
+2 SET DIR(0)="S^1:ACCOUNT CODE;2:NSN"
SET DIR("A")="Sort BY"
SET DIR("B")="ACCOUNT CODE"
DO ^DIR
KILL DIR
IF Y'=1
IF Y'=2
QUIT 0
+3 QUIT +Y
+4 ;
+5 ;
SUMMARY() ; print summary only
+1 NEW %,X
+2 KILL X
SET X(1)="Display Summary or ALL Data."
DO DISPLAY^PRCPUX2(2,40,.X)
+3 SET XP="Do you want to print a summary only"
SET XH="Enter 'YES' to print a summary, 'NO' to print entire report, '^' to exit."
+4 SET %=$$YN^PRCPUYN(1)
+5 QUIT $SELECT(%=1:1,%=2:0,1:-1)
+6 ;
+7 ;
ACCTSEL ; pick account codes or all
+1 ; returns array of accounts selected
+2 NEW %,A,DIR,DIRUT,DTOUT,DUOUT,PRCPEXIT,PRCPFLAG,PRCPLINE,X,Y
+3 SET PRCPLINE=""
SET $PIECE(PRCPLINE,"-",78)=""
+4 KILL ACCOUNT
+5 FOR %=1,2,3,6,8
SET ACCOUNT("NO",%)=""
+6 FOR
Begin DoDot:1
+7 WRITE !
+8 IF $ORDER(ACCOUNT("YES",0))
Begin DoDot:2
+9 WRITE !?2,PRCPLINE,!?2,"| Currently selected account codes : "
+10 SET A=0
FOR
SET A=$ORDER(ACCOUNT("YES",A))
if 'A
QUIT
WRITE A
if $ORDER(ACCOUNT("YES",A))
WRITE ", "
+11 WRITE ?78,"|",!?2,"| You can DE-select one of the above account codes by reselecting it.",?78,"|"
End DoDot:2
+12 IF $ORDER(ACCOUNT("NO",0))
Begin DoDot:2
+13 WRITE !?2,PRCPLINE,!?2,"| Currently DE-selected account codes: "
+14 SET A=0
FOR
SET A=$ORDER(ACCOUNT("NO",A))
if 'A
QUIT
WRITE A
if $ORDER(ACCOUNT("NO",A))
WRITE ", "
+15 WRITE ?78,"|",!?2,"| You can RE-select one of the above account codes by reselecting it.",?78,"|"
End DoDot:2
+16 WRITE !?2,PRCPLINE
+17 SET DIR(0)="SBO^1:Account Code 1;2:Account Code 2;3:Account Code 3;6:Account Code 6;8:Account Code 8;"
SET DIR("A")="Select ACCOUNT Code"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET (PRCPFLAG,PRCPEXIT)=1
QUIT
+18 SET Y=+Y
+19 IF Y=0
IF '$ORDER(ACCOUNT("YES",0))
Begin DoDot:2
+20 SET %=$$ALLACCT
IF %=0
QUIT
+21 IF %=1
KILL ACCOUNT("NO")
FOR %=1,2,3,6,8
SET ACCOUNT("YES",%)=""
End DoDot:2
IF %=0
SET (PRCPFLAG,PRCPEXIT)=1
QUIT
+22 IF Y=0
SET PRCPFLAG=1
QUIT
+23 IF $DATA(ACCOUNT("YES",Y))
KILL ACCOUNT("YES",Y)
SET ACCOUNT("NO",Y)=""
WRITE !?10,"DE-selected !"
QUIT
+24 IF $DATA(ACCOUNT("NO",Y))
KILL ACCOUNT("NO",Y)
SET ACCOUNT("YES",Y)=""
WRITE !?10,"RE-selected !"
QUIT
+25 SET ACCOUNT("YES",Y)=""
WRITE !?10,"selected !"
End DoDot:1
IF $GET(PRCPFLAG)
QUIT
+26 IF $GET(PRCPEXIT)
KILL ACCOUNT
+27 KILL ACCOUNT("NO")
+28 WRITE !!,"*** Selected Account Codes: "
IF '$ORDER(ACCOUNT("YES",0))
WRITE "<<NONE>>"
QUIT
+29 SET A=0
FOR
SET A=$ORDER(ACCOUNT("YES",A))
if 'A
QUIT
WRITE A
if $ORDER(ACCOUNT("YES",A))
WRITE ", "
SET ACCOUNT(A)=""
+30 KILL ACCOUNT("YES")
+31 QUIT
+32 ;
ALLACCT() ; select all account codes
+1 ; returns 1 for yes, 2 for no, 0 for ^
+2 SET XP="Do you want to select ALL account codes"
SET XH="Enter 'YES' to select all account codes, 'NO' to not select all account codes."
+3 WRITE !
+4 QUIT $$YN^PRCPUYN(1)
+5 ;
+6 ;
NSNSEL ; start with and end with nsn
+1 ; returns prcpstrt and prcpend
+2 NEW PRCPFLAG,X
+3 KILL PRCPSTRT,PRCPEND
+4 FOR
Begin DoDot:1
+5 WRITE !,"START with NSN: FIRST// "
READ X:DTIME
IF '$TEST!(X["^")
SET PRCPFLAG=1
QUIT
+6 IF X["?"
WRITE !?2,"Select the starting NSN value. If you select the default FIRST entry, NULL",!?2,"NSN entries will be selected. If you select 6505, all NSNs starting with",!?2,"6505 will be selected."
QUIT
+7 IF X'=""
IF '$$NSNCHECK(X)
WRITE !?5,"Invalid NSN format. Format should be in the form 6505-22-333-4444."
QUIT
+8 SET PRCPSTRT=X
SET PRCPFLAG=1
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+9 IF '$DATA(PRCPSTRT)
QUIT
+10 KILL PRCPFLAG
+11 FOR
Begin DoDot:1
+12 WRITE !," END with NSN: LAST// "
READ X:DTIME
IF '$TEST!(X["^")
SET PRCPFLAG=1
QUIT
+13 IF X=" "
SET X=PRCPSTRT
WRITE " ",X
+14 IF X["?"
Begin DoDot:2
+15 WRITE !?2,"Select the ending NSN value."
+16 IF PRCPSTRT=""
QUIT
+17 WRITE " If you start with ",PRCPSTRT," and end with ",PRCPSTRT,",",!?2,"you will only select NSNs which begin with ",PRCPSTRT,"."
+18 WRITE !," Also, enter the <space bar> to set the ending NSN equal to the starting NSN."
End DoDot:2
QUIT
+19 IF X'=""
IF '$$NSNCHECK(X)
WRITE !?5,"Invalid NSN format. Format should be in the form 6505-22-333-4444."
QUIT
+20 IF X=""
SET X="z"
+21 IF PRCPSTRT]X
WRITE !?4,"Ending NSN must follow starting NSN."
QUIT
+22 SET PRCPEND=X
SET PRCPFLAG=1
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+23 IF '$DATA(PRCPEND)
KILL PRCPSTRT
QUIT
+24 QUIT
+25 ;
NSNCHECK(V1) ; nsn format check
+1 IF V1?4N
QUIT 1
+2 IF V1?4N1"-"2UN
QUIT 1
+3 IF V1?4N1"-"2UN1"-"3N
QUIT 1
+4 IF V1?4N1"-"2UN1"-"3N1"-"4N.A
QUIT 1
+5 QUIT 0
