- PRCH1E ;WISC/PLT-IFCAP RETRIEVE UNREGISTERED PURCHASE CARD CHARGES ;10/15/97 14:26
- V ;;5.1;IFCAP;**8**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- QUIT ;invalid entry
- ;
- EN ;retrieve unregistered purchase card charges
- N PRCA,PRCB,PRCRI
- N A,B,C
- S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
- Q1 D YN^PRC0A(.X,.Y,"Ready to Retrieve Unregistered Purchase Card Charges","O","YES")
- I X["^"!(X="")!'Y G EXIT
- D EN^DDIOL("Start Retrieving:")
- S PRCRI=0,PRCTR=0
- F S PRCRI=$O(^PRCH(440.6,"ST","N~",PRCRI)) QUIT:'PRCRI D:$P(^PRCH(440.6,PRCRI,0),"^",17)="" K:$P(^PRCH(440.6,PRCRI,0),"^",17) ^PRCH(440.6,"ST","N~",PRCRI)
- . N A,B,C,X,Y
- . S A=^PRCH(440.6,PRCRI,0),B=$P(A,"^",4),PRCRI(440.5)=$O(^PRC(440.5,"B",B,0))
- . QUIT:'PRCRI(440.5)
- . S PRCRI(200)=$P(^PRC(440.5,PRCRI(440.5),0),"^",8) QUIT:PRCRI(200)=""
- . I $D(PRC("SITE")) Q:$P(^PRC(440.5,PRCRI(440.5),2),"^",3)'=PRC("SITE")
- . W "." D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI,"16////"_PRCRI(200))
- . S PRCTR=$G(PRCTR)+1
- . QUIT
- ;
- I $G(PRCTR)>0 W !!?5,"Found "_PRCTR_" charge(s). Task completed !!" H 2
- I $G(PRCTR)=0 W !!?5,"No charges were found. Task completed !!" H 2
- K PRCTR
- EXIT QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH1E 1227 printed Feb 18, 2025@23:31:32 Page 2
- PRCH1E ;WISC/PLT-IFCAP RETRIEVE UNREGISTERED PURCHASE CARD CHARGES ;10/15/97 14:26
- V ;;5.1;IFCAP;**8**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;invalid entry
- QUIT
- +3 ;
- EN ;retrieve unregistered purchase card charges
- +1 NEW PRCA,PRCB,PRCRI
- +2 NEW A,B,C
- +3 SET PRCF("X")="S"
- DO ^PRCFSITE
- if '$DATA(PRC("SITE"))
- QUIT
- if $GET(X)="^"
- QUIT
- Q1 DO YN^PRC0A(.X,.Y,"Ready to Retrieve Unregistered Purchase Card Charges","O","YES")
- +1 IF X["^"!(X="")!'Y
- GOTO EXIT
- +2 DO EN^DDIOL("Start Retrieving:")
- +3 SET PRCRI=0
- SET PRCTR=0
- +4 FOR
- SET PRCRI=$ORDER(^PRCH(440.6,"ST","N~",PRCRI))
- if 'PRCRI
- QUIT
- if $PIECE(^PRCH(440.6,PRCRI,0),"^",17)=""
- Begin DoDot:1
- +5 NEW A,B,C,X,Y
- +6 SET A=^PRCH(440.6,PRCRI,0)
- SET B=$PIECE(A,"^",4)
- SET PRCRI(440.5)=$ORDER(^PRC(440.5,"B",B,0))
- +7 if 'PRCRI(440.5)
- QUIT
- +8 SET PRCRI(200)=$PIECE(^PRC(440.5,PRCRI(440.5),0),"^",8)
- if PRCRI(200)=""
- QUIT
- +9 IF $DATA(PRC("SITE"))
- if $PIECE(^PRC(440.5,PRCRI(440.5),2),"^",3)'=PRC("SITE")
- QUIT
- +10 WRITE "."
- DO EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI,"16////"_PRCRI(200))
- +11 SET PRCTR=$GET(PRCTR)+1
- +12 QUIT
- End DoDot:1
- if $PIECE(^PRCH(440.6,PRCRI,0),"^",17)
- KILL ^PRCH(440.6,"ST","N~",PRCRI)
- +13 ;
- +14 IF $GET(PRCTR)>0
- WRITE !!?5,"Found "_PRCTR_" charge(s). Task completed !!"
- HANG 2
- +15 IF $GET(PRCTR)=0
- WRITE !!?5,"No charges were found. Task completed !!"
- HANG 2
- +16 KILL PRCTR
- EXIT QUIT