- PRCSX123 ;RB-SET TRANSACTION SEQUENCE FOR ALL 9999 ENTRIES
- V ;;5.1;IFCAP;**123**;MAR 25, 2009;Build 6
- ;Per VHA Directive 2004-038, this routine should not be modified
- Q ;STOPS TOP DOWN ENTRY
- EN ;For patch RMPR*3.0*151 testing only and only on test system
- ;Sets PRCS(410,"B" nodes for all 9999 entries for station,FY,fiscal qtr and FCP
- I $$PROD^XUPROD() W !,"Can ONLY be run on test/mirror system" Q
- W #,"The following process will set all unused transaction numbers through 9999 for"
- W !,"selected station, FY, FQ and FCP used when entering a Prosthetics GUI PO",!!
- S TOT=0
- 1 R !!,"ENTER STATION: ",PRCSTA:60 Q:PRCSTA=""!(PRCSTA["^")
- 2 R !!,"ENTER FISCAL YEAR (EX. 09): ",PRCFY:60 G 1:PRCFY=""!(PRCFY["^")
- I $L(PRCFY)'=2 W ?30,"FISCAL YEAR MUST BE 2 DIGITS" G 2
- 3 R !!,"ENTER FISCAL QUARTER (1-4): ",PRCFQ:60 G 2:PRCFQ=""!(PRCFQ["^")
- I "1234"'[PRCFQ!($L(PRCFQ)>1) W ?40,"INVALID FISCAL QUARTER, MUST BE 1-4" G 3
- 4 R !!,"ENTER FUND CONTROL POINT (FOR PROSTHETICS ORDERS): ",PRCFCP:60 G 3:PRCFCP=""!(PRCFCP["^")
- I '$D(^PRC(420,PRCSTA,1,+PRCFCP)) W ?40,"INVALID FCP USED" G 4
- S CHK=PRCSTA_"-"_PRCFY_"-"_PRCFCP
- I '$D(^PRCS(410.1,"B",CHK)) W !!,CHK,"IS NOT A VALID SEQUENCE START BASE POINT FOR FILE ^PRCS(410.1,""B"")",!,"** You MUST enter accurate station, FY and FCP that you will using when doing Prosthetics GUI PO" G 1
- S PRCSIEN=$O(^PRCS(410.1,"B",CHK,0)),PRCRSQSV=$P($G(^PRCS(410.1,PRCSIEN,0)),"^",2)
- F I=1:1:9998 D
- . S PRCSQ=$E("000",1,4-$L(I))_I
- . S PRCRSQ=PRCSTA_"-"_PRCFY_"-"_PRCFQ_"-"_PRCFCP_"-"_PRCSQ
- . I $D(^PRCS(410,"B",PRCRSQ)) W !,"** ALREADY USED: ",PRCRSQ Q
- . S ^PRCS(410,"B",PRCRSQ,111)="##",TOT=TOT+1
- . W !,"SET ^PRCS(410,""B"",",PRCRSQ,",111)=##"
- S PRCSIEN=$O(^PRCS(410.1,"B",PRCSTA_"-"_PRCFY_"-"_PRCFCP,"")) I PRCSIEN S $P(^PRCS(410.1,PRCSIEN,0),"^",2)=9998,$P(^PRCS(410.1,PRCSIEN,0),"^",5)=PRCRSQSV
- W !!,"** ALL 9999 SLOTS HAVE BEEN SET FOR REQ #: ",$P(PRCRSQ,"-",1,4)," TOTAL SET = ",TOT
- W !!,"PATCH RMPR*3.0*151 MAY BE TESTED AT THIS POINT"
- K PRCSTA,PRCFY,PRCFQ,PRCFCP,I,PRCSQ,PRCRSQ,XX,CHK,PRCSIEN,PRCRSQSV,TOT
- Q
- DEL ;DELETE DUMMY ^PRCS(410,"B" ENTRIES CREATED FOR RMPR*3.0*151 TESTING
- I $$PROD^XUPROD() W !,"Can ONLY be run on test/mirror system" Q
- S IEN=0,PRCRSQ=0,TOT=0
- F S PRCRSQ=$O(^PRCS(410,"B",PRCRSQ)),IEN=0 Q:PRCRSQ="" D
- . F S IEN=$O(^PRCS(410,"B",PRCRSQ,IEN)) Q:IEN="" D
- .. S PRCREC=^PRCS(410,"B",PRCRSQ,IEN) Q:PRCREC'="##"
- .. W !,"KILLING ^PRCS(410,""B"",",PRCRSQ,",",IEN S HPRCRSQ=PRCRSQ,TOT=TOT+1
- .. K ^PRCS(410,"B",PRCRSQ,IEN)
- I TOT=0 G DQ
- S PRCRSQ=$P(HPRCRSQ,"-")_"-"_$P(HPRCRSQ,"-",2)_"-"_$P(HPRCRSQ,"-",4)
- S PRCSIEN=$O(^PRCS(410.1,"B",PRCRSQ,"")) I PRCSIEN S $P(^PRCS(410.1,PRCSIEN,0),"^",2)=$P(^PRCS(410.1,PRCSIEN,0),"^",5),$P(^PRCS(410.1,PRCSIEN,0),"^",5)=""
- W !!,"ALL ADDED (",TOT,") TESTING ENTRIES FOR REQ SERIES ",$P(HPRCRSQ,"-",1,4)," HAVE BEEN DELETED",!
- DQ K IEN,PRCRSQ,PRCSIEN,HPRCRSQ,TOT,PRCREC
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSX123 2934 printed Mar 13, 2025@21:24:02 Page 2
- PRCSX123 ;RB-SET TRANSACTION SEQUENCE FOR ALL 9999 ENTRIES
- V ;;5.1;IFCAP;**123**;MAR 25, 2009;Build 6
- +1 ;Per VHA Directive 2004-038, this routine should not be modified
- +2 ;STOPS TOP DOWN ENTRY
- QUIT
- EN ;For patch RMPR*3.0*151 testing only and only on test system
- +1 ;Sets PRCS(410,"B" nodes for all 9999 entries for station,FY,fiscal qtr and FCP
- +2 IF $$PROD^XUPROD()
- WRITE !,"Can ONLY be run on test/mirror system"
- QUIT
- +3 WRITE #,"The following process will set all unused transaction numbers through 9999 for"
- +4 WRITE !,"selected station, FY, FQ and FCP used when entering a Prosthetics GUI PO",!!
- +5 SET TOT=0
- 1 READ !!,"ENTER STATION: ",PRCSTA:60
- if PRCSTA=""!(PRCSTA["^")
- QUIT
- 2 READ !!,"ENTER FISCAL YEAR (EX. 09): ",PRCFY:60
- if PRCFY=""!(PRCFY["^")
- GOTO 1
- +1 IF $LENGTH(PRCFY)'=2
- WRITE ?30,"FISCAL YEAR MUST BE 2 DIGITS"
- GOTO 2
- 3 READ !!,"ENTER FISCAL QUARTER (1-4): ",PRCFQ:60
- if PRCFQ=""!(PRCFQ["^")
- GOTO 2
- +1 IF "1234"'[PRCFQ!($LENGTH(PRCFQ)>1)
- WRITE ?40,"INVALID FISCAL QUARTER, MUST BE 1-4"
- GOTO 3
- 4 READ !!,"ENTER FUND CONTROL POINT (FOR PROSTHETICS ORDERS): ",PRCFCP:60
- if PRCFCP=""!(PRCFCP["^")
- GOTO 3
- +1 IF '$DATA(^PRC(420,PRCSTA,1,+PRCFCP))
- WRITE ?40,"INVALID FCP USED"
- GOTO 4
- +2 SET CHK=PRCSTA_"-"_PRCFY_"-"_PRCFCP
- +3 IF '$DATA(^PRCS(410.1,"B",CHK))
- WRITE !!,CHK,"IS NOT A VALID SEQUENCE START BASE POINT FOR FILE ^PRCS(410.1,""B"")",!,"** You MUST enter accurate station, FY and FCP that you will using when doing Prosthetics GUI PO"
- GOTO 1
- +4 SET PRCSIEN=$ORDER(^PRCS(410.1,"B",CHK,0))
- SET PRCRSQSV=$PIECE($GET(^PRCS(410.1,PRCSIEN,0)),"^",2)
- +5 FOR I=1:1:9998
- Begin DoDot:1
- +6 SET PRCSQ=$EXTRACT("000",1,4-$LENGTH(I))_I
- +7 SET PRCRSQ=PRCSTA_"-"_PRCFY_"-"_PRCFQ_"-"_PRCFCP_"-"_PRCSQ
- +8 IF $DATA(^PRCS(410,"B",PRCRSQ))
- WRITE !,"** ALREADY USED: ",PRCRSQ
- QUIT
- +9 SET ^PRCS(410,"B",PRCRSQ,111)="##"
- SET TOT=TOT+1
- +10 WRITE !,"SET ^PRCS(410,""B"",",PRCRSQ,",111)=##"
- End DoDot:1
- +11 SET PRCSIEN=$ORDER(^PRCS(410.1,"B",PRCSTA_"-"_PRCFY_"-"_PRCFCP,""))
- IF PRCSIEN
- SET $PIECE(^PRCS(410.1,PRCSIEN,0),"^",2)=9998
- SET $PIECE(^PRCS(410.1,PRCSIEN,0),"^",5)=PRCRSQSV
- +12 WRITE !!,"** ALL 9999 SLOTS HAVE BEEN SET FOR REQ #: ",$PIECE(PRCRSQ,"-",1,4)," TOTAL SET = ",TOT
- +13 WRITE !!,"PATCH RMPR*3.0*151 MAY BE TESTED AT THIS POINT"
- +14 KILL PRCSTA,PRCFY,PRCFQ,PRCFCP,I,PRCSQ,PRCRSQ,XX,CHK,PRCSIEN,PRCRSQSV,TOT
- +15 QUIT
- DEL ;DELETE DUMMY ^PRCS(410,"B" ENTRIES CREATED FOR RMPR*3.0*151 TESTING
- +1 IF $$PROD^XUPROD()
- WRITE !,"Can ONLY be run on test/mirror system"
- QUIT
- +2 SET IEN=0
- SET PRCRSQ=0
- SET TOT=0
- +3 FOR
- SET PRCRSQ=$ORDER(^PRCS(410,"B",PRCRSQ))
- SET IEN=0
- if PRCRSQ=""
- QUIT
- Begin DoDot:1
- +4 FOR
- SET IEN=$ORDER(^PRCS(410,"B",PRCRSQ,IEN))
- if IEN=""
- QUIT
- Begin DoDot:2
- +5 SET PRCREC=^PRCS(410,"B",PRCRSQ,IEN)
- if PRCREC'="##"
- QUIT
- +6 WRITE !,"KILLING ^PRCS(410,""B"",",PRCRSQ,",",IEN
- SET HPRCRSQ=PRCRSQ
- SET TOT=TOT+1
- +7 KILL ^PRCS(410,"B",PRCRSQ,IEN)
- End DoDot:2
- End DoDot:1
- +8 IF TOT=0
- GOTO DQ
- +9 SET PRCRSQ=$PIECE(HPRCRSQ,"-")_"-"_$PIECE(HPRCRSQ,"-",2)_"-"_$PIECE(HPRCRSQ,"-",4)
- +10 SET PRCSIEN=$ORDER(^PRCS(410.1,"B",PRCRSQ,""))
- IF PRCSIEN
- SET $PIECE(^PRCS(410.1,PRCSIEN,0),"^",2)=$PIECE(^PRCS(410.1,PRCSIEN,0),"^",5)
- SET $PIECE(^PRCS(410.1,PRCSIEN,0),"^",5)=""
- +11 WRITE !!,"ALL ADDED (",TOT,") TESTING ENTRIES FOR REQ SERIES ",$PIECE(HPRCRSQ,"-",1,4)," HAVE BEEN DELETED",!
- DQ KILL IEN,PRCRSQ,PRCSIEN,HPRCRSQ,TOT,PRCREC
- +1 QUIT
