- 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 Jan 18, 2025@03:17:29 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