- PRCSUT1 ;SF-ISC/LJP/KSS/KMB/DGL-CONTROL POINT UTILITY ROUTINE ;8/25/00 16:45
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;find #requests to approve/process, ACTION FOR 'PRCSCP OFFICIAL' OPTION.
- N PRC,PRCSAMT,PRCSCT,PRCSDA,PRCSI,PRCSJ,PRCSK,PRCSKS,PRCSVAR
- ; APPREQ=1 if user entered from approve requests procedure [PRCSAPP]
- Q:'$D(DUZ) S (PRC("CP"),PRC("SITE"))=0,U="^"
- ;
- F PRCSI=0:0 D Q:PRC("SITE")'>0 ; for each station the user accesses
- . S PRC("SITE")=$O(^PRC(420,"A",DUZ,PRC("SITE")))
- . Q:PRC("SITE")'>0
- . ;
- . F PRCSJ=0:0 D Q:PRC("CP")'>0 ; and for each CP at that station
- . . S PRC("CP")=$O(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP")))
- . . Q:PRC("CP")'>0
- . . I $D(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP"),1)) D
- . . . ;
- . . . ; if the user is an official for that station and CP
- . . . S (PRCSAMT,PRCSCT)=0 ; $value,counter
- . . . S PRCSVAR=PRC("SITE")_"-"_+PRC("CP")
- . . . S PRCSKS=PRCSVAR_"-"_0 ; station-CP-counter
- . . . ;
- . . . F PRCSK=0:0 D Q:PRCSK=1 ; find all txns to be approved
- . . . . S PRCSKS=$O(^PRCS(410,"F",PRCSVAR_"-"_$P(PRCSKS,"-",3)))
- . . . . I $P(PRCSVAR,"-",1,2)'=$P(PRCSKS,"-",1,2)!(PRCSKS="") S PRCSK=1 Q
- . . . . S PRCSDA=$O(^PRCS(410,"F",PRCSKS,0)) ; get ien
- . . . . Q:PRCSDA'>0
- . . . . I $$MAINT(PRCSKS,PRCSDA)=1 Q ; pointer values are wrong
- . . . . S PRCSCT=PRCSCT+1
- . . . . I $D(^PRCS(410,PRCSDA,4))
- . . . . I S PRCSAMT=PRCSAMT+$S($P(^PRCS(410,PRCSDA,4),U):$P(^PRCS(410,PRCSDA,4),U),$P(^PRCS(410,PRCSDA,0),U,2)="A"&($P(^PRCS(410,PRCSDA,0),U,4)=1):$P(^PRCS(410,PRCSDA,4),U,6),1:0)
- . . . ;
- . . . Q:'PRCSCT ; no txns awaiting approval
- . . . I $D(APPREQ) S CPCK(PRC("CP"))="" Q
- . . . W !,"You have "_PRCSCT_" request(s) to approve in station "_PRC("SITE")_", CP ",PRC("CP"),?60,"$: "_$J(PRCSAMT,9,2)
- . . . Q
- . . . ;
- . . Q:$D(APPREQ)
- . . ; if user is a clerk for this site and CP check processing queue
- . . I $D(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP"),2)) D CHECK^PRCSRDIS
- ;
- Q
- MAINT(TN,DA) ; returns 1 if 'F' subscripts inconsistent with master file data
- ; TN = Transaction name, DA = ien
- ; kills x-refs that are not correct
- N X,Y,U
- S Y=0 ; flag=0 if maintenance not required
- S U="^"
- I '$D(^PRCS(410,DA,0)) S Y=1 G MAINTQ ; shouldn't the xrefs be killed?
- ; if document is signed by an aproving official, kill xrefs
- I $D(^PRCS(410,DA,7)),$P(^PRCS(410,DA,7),U,6)]"" S Y=1 D KXREF G MAINTQ
- ; if document is not ready for approval, kill x-refs
- I $S('$D(^PRCS(410,DA,11)):1,'$P(^PRCS(410,DA,11),U,3):1,1:0)
- I S Y=1 D KXREF G MAINTQ
- S X=$P($P(^PRCS(410,DA,0),U),"-",4,5)
- ; if the CP or counter in 'F' differs from txn name at ien in 410 file
- I +$P(X,"-")'=$P(TN,"-",2)!($P(X,"-",2)'=$P(TN,"-",3))
- I S Y=1
- I K ^PRCS(410,"F",TN,DA)
- I K ^PRCS(410,"F1",$P(TN,"-",3)_"-"_$P(TN,"-",1,2),DA)
- MAINTQ Q Y
- KXREF ;KILL F,F1 AND AQ CROSS REFERENCES
- K ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA)
- K ^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA)
- K ^PRCS(410,"AQ",1,DA)
- Q
- ;
- K ;
- S X=+T2_"-"_+$P(T2,"-",4)_"-"_$P(T2,"-",5)
- K ^PRCS(410,"F",X,DA)
- S X=$P(X,"-",3)_"-"_$P(X,"-",1,2)
- K ^PRCS(410,"F1",X,DA)
- Q
- ;
- CPF(PRCIPFLG) ; Entry point for Inv. Pt. selection
- CP ;CONTROL POINT SCREEN FROM MENU
- I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
- K PRCSIP ; inventory distribution point variable
- S DIC="^PRC(420,"_PRC("SITE")_",1,"
- S DIC(0)="AEMNQZ"
- S DIC("A")="Select CONTROL POINT: "
- I $D(PRC("CP")) S DIC("B")=$S($D(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP"),PRCSC)):PRC("CP"),1:"")
- S DIC("S")="I '$P(^(0),U,19),$S($D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,PRCSC)):1,"
- I PRCSC=1 S DIC("S")=DIC("S")_"$O(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,0))=(PRCSC+1):1,1:0)"
- I PRCSC=2 S DIC("S")=DIC("S")_"$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,PRCSC)):1,1:0)"
- I PRCSC=3 S DIC("S")=DIC("S")_"$P(^PRC(420,PRC(""SITE""),1,+Y,0),U,9)=""Y""!($O(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,0))>0):1,1:0)"
- I PRCSC=4 K DIC("S")
- S D="B^C" D MIX^DIC1 K DIC("A"),DIC("B"),DIC("S")
- Q:Y<0
- S PRC("CP")=$P(Y(0),U)
- I PRCIPFLG=1 D IP^PRCSUT
- Q
- PRT ;REQUESTS TO BE APPROVED LIST
- D EN3^PRCSUT
- G W2^PRCSEB:'$D(PRC("SITE"))
- G END:Y<0
- S L=0,DIC="^PRCS(410,"
- S FLDS="[PRCS REQUESTS FOR APPROVAL]"
- S BY="'55"
- S (FR,TO)=""
- S DIS(0)="I $D(^PRCS(410,D0,0)),$P($G(^PRCS(410,D0,0)),""-"")=PRC(""SITE""),$P(^(0),""-"",4)=$P(PRC(""CP""),"" ""),$P($G(^PRCS(410,D0,1)),U,2)="""""
- D EN1^DIP
- R !,"Press return to continue or uparrow to exit: ",X:DTIME,!
- Q:('$T)!(X'="")
- G PRT
- END Q
- RL ;RENUMBER LINE ITEMS
- K I
- I $D(^PRCS(410,DA,"IT",0)) K ^("AB"),^("B") S Z=0 F I=1:1 S Z=$O(^PRCS(410,DA,"IT",Z)) Q:Z'>0 S L=^(Z,0) S ^(0)=I_U_$P(^(0),U,2,99) S ^PRCS(410,DA,"IT","B",I,Z)="",^PRCS(410,DA,"IT","AB",I,Z)=""
- S I=$S($D(I):I-1,1:0)
- S ^PRCS(410,DA,10)=$S($D(^PRCS(410,DA,10)):I_U_$P(^(10),U,2,99),1:I)
- K I,L,Z
- Q
- RLR ;RENUMBER LINE ITEMS IN REP ITEM LIST FILE
- K I,L
- Q:'$D(^PRCS(410.3,D0,1,0))
- K ^("AC"),^("B")
- S (PRCSCS,Z)=0
- F I=1:1 S Z=$O(^PRCS(410.3,D0,1,Z)) Q:Z'>0 S L(I)=^(Z,0) K ^PRCS(410.3,D0,1,Z,0)
- K Z
- S I=0
- F J=1:1 S I=$O(L(I)) Q:I'>0 S Z=L(I),^PRCS(410.3,D0,1,J,0)=+Z_U_$P(Z,U,2,99) S PRCSCS=PRCSCS+($P(Z,U,2)*$P(Z,U,4)),^PRCS(410.3,D0,1,"AC",$P(Z,U,3),I)="",^PRCS(410.3,D0,1,"B",+Z,I)=""
- S $P(^PRCS(410.3,D0,1,0),U,3,4)=(J-1)_U_(J-1),$P(^PRCS(410.3,D0,0),U,2)=PRCSCS
- K I,L,PRCSCS,Z
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSUT1 5503 printed Feb 18, 2025@23:45:30 Page 2
- PRCSUT1 ;SF-ISC/LJP/KSS/KMB/DGL-CONTROL POINT UTILITY ROUTINE ;8/25/00 16:45
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;find #requests to approve/process, ACTION FOR 'PRCSCP OFFICIAL' OPTION.
- +3 NEW PRC,PRCSAMT,PRCSCT,PRCSDA,PRCSI,PRCSJ,PRCSK,PRCSKS,PRCSVAR
- +4 ; APPREQ=1 if user entered from approve requests procedure [PRCSAPP]
- +5 if '$DATA(DUZ)
- QUIT
- SET (PRC("CP"),PRC("SITE"))=0
- SET U="^"
- +6 ;
- +7 ; for each station the user accesses
- FOR PRCSI=0:0
- Begin DoDot:1
- +8 SET PRC("SITE")=$ORDER(^PRC(420,"A",DUZ,PRC("SITE")))
- +9 if PRC("SITE")'>0
- QUIT
- +10 ;
- +11 ; and for each CP at that station
- FOR PRCSJ=0:0
- Begin DoDot:2
- +12 SET PRC("CP")=$ORDER(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP")))
- +13 if PRC("CP")'>0
- QUIT
- +14 IF $DATA(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP"),1))
- Begin DoDot:3
- +15 ;
- +16 ; if the user is an official for that station and CP
- +17 ; $value,counter
- SET (PRCSAMT,PRCSCT)=0
- +18 SET PRCSVAR=PRC("SITE")_"-"_+PRC("CP")
- +19 ; station-CP-counter
- SET PRCSKS=PRCSVAR_"-"_0
- +20 ;
- +21 ; find all txns to be approved
- FOR PRCSK=0:0
- Begin DoDot:4
- +22 SET PRCSKS=$ORDER(^PRCS(410,"F",PRCSVAR_"-"_$PIECE(PRCSKS,"-",3)))
- +23 IF $PIECE(PRCSVAR,"-",1,2)'=$PIECE(PRCSKS,"-",1,2)!(PRCSKS="")
- SET PRCSK=1
- QUIT
- +24 ; get ien
- SET PRCSDA=$ORDER(^PRCS(410,"F",PRCSKS,0))
- +25 if PRCSDA'>0
- QUIT
- +26 ; pointer values are wrong
- IF $$MAINT(PRCSKS,PRCSDA)=1
- QUIT
- +27 SET PRCSCT=PRCSCT+1
- +28 IF $DATA(^PRCS(410,PRCSDA,4))
- +29 IF $TEST
- SET PRCSAMT=PRCSAMT+$SELECT($PIECE(^PRCS(410,PRCSDA,4),U):$PIECE(^PRCS(410,PRCSDA,4),U),$PIECE(^PRCS(410,PRCSDA,0),U,2)="A"&($PIECE(^PRCS(410,PRCSDA,0),U,4)=1):$PIECE(^PRCS(410,PRCSDA,4),U,6),1:0)
- End DoDot:4
- if PRCSK=1
- QUIT
- +30 ;
- +31 ; no txns awaiting approval
- if 'PRCSCT
- QUIT
- +32 IF $DATA(APPREQ)
- SET CPCK(PRC("CP"))=""
- QUIT
- +33 WRITE !,"You have "_PRCSCT_" request(s) to approve in station "_PRC("SITE")_", CP ",PRC("CP"),?60,"$: "_$JUSTIFY(PRCSAMT,9,2)
- +34 QUIT
- +35 ;
- End DoDot:3
- +36 if $DATA(APPREQ)
- QUIT
- +37 ; if user is a clerk for this site and CP check processing queue
- +38 IF $DATA(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP"),2))
- DO CHECK^PRCSRDIS
- End DoDot:2
- if PRC("CP")'>0
- QUIT
- End DoDot:1
- if PRC("SITE")'>0
- QUIT
- +39 ;
- +40 QUIT
- MAINT(TN,DA) ; returns 1 if 'F' subscripts inconsistent with master file data
- +1 ; TN = Transaction name, DA = ien
- +2 ; kills x-refs that are not correct
- +3 NEW X,Y,U
- +4 ; flag=0 if maintenance not required
- SET Y=0
- +5 SET U="^"
- +6 ; shouldn't the xrefs be killed?
- IF '$DATA(^PRCS(410,DA,0))
- SET Y=1
- GOTO MAINTQ
- +7 ; if document is signed by an aproving official, kill xrefs
- +8 IF $DATA(^PRCS(410,DA,7))
- IF $PIECE(^PRCS(410,DA,7),U,6)]""
- SET Y=1
- DO KXREF
- GOTO MAINTQ
- +9 ; if document is not ready for approval, kill x-refs
- +10 IF $SELECT('$DATA(^PRCS(410,DA,11)):1,'$PIECE(^PRCS(410,DA,11),U,3):1,1:0)
- +11 IF $TEST
- SET Y=1
- DO KXREF
- GOTO MAINTQ
- +12 SET X=$PIECE($PIECE(^PRCS(410,DA,0),U),"-",4,5)
- +13 ; if the CP or counter in 'F' differs from txn name at ien in 410 file
- +14 IF +$PIECE(X,"-")'=$PIECE(TN,"-",2)!($PIECE(X,"-",2)'=$PIECE(TN,"-",3))
- +15 IF $TEST
- SET Y=1
- +16 IF $TEST
- KILL ^PRCS(410,"F",TN,DA)
- +17 IF $TEST
- KILL ^PRCS(410,"F1",$PIECE(TN,"-",3)_"-"_$PIECE(TN,"-",1,2),DA)
- MAINTQ QUIT Y
- KXREF ;KILL F,F1 AND AQ CROSS REFERENCES
- +1 KILL ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$PIECE($PIECE(^PRCS(410,DA,0),U),"-",5),DA)
- +2 KILL ^PRCS(410,"F1",$PIECE($PIECE(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA)
- +3 KILL ^PRCS(410,"AQ",1,DA)
- +4 QUIT
- +5 ;
- K ;
- +1 SET X=+T2_"-"_+$PIECE(T2,"-",4)_"-"_$PIECE(T2,"-",5)
- +2 KILL ^PRCS(410,"F",X,DA)
- +3 SET X=$PIECE(X,"-",3)_"-"_$PIECE(X,"-",1,2)
- +4 KILL ^PRCS(410,"F1",X,DA)
- +5 QUIT
- +6 ;
- CPF(PRCIPFLG) ; Entry point for Inv. Pt. selection
- CP ;CONTROL POINT SCREEN FROM MENU
- +1 IF '$GET(PRCIPFLG)
- if '$DATA(PRCIPFLG)
- NEW PRCIPFLG
- SET PRCIPFLG=0
- +2 ; inventory distribution point variable
- KILL PRCSIP
- +3 SET DIC="^PRC(420,"_PRC("SITE")_",1,"
- +4 SET DIC(0)="AEMNQZ"
- +5 SET DIC("A")="Select CONTROL POINT: "
- +6 IF $DATA(PRC("CP"))
- SET DIC("B")=$SELECT($DATA(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP"),PRCSC)):PRC("CP"),1:"")
- +7 SET DIC("S")="I '$P(^(0),U,19),$S($D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,PRCSC)):1,"
- +8 IF PRCSC=1
- SET DIC("S")=DIC("S")_"$O(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,0))=(PRCSC+1):1,1:0)"
- +9 IF PRCSC=2
- SET DIC("S")=DIC("S")_"$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,PRCSC)):1,1:0)"
- +10 IF PRCSC=3
- SET DIC("S")=DIC("S")_"$P(^PRC(420,PRC(""SITE""),1,+Y,0),U,9)=""Y""!($O(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,0))>0):1,1:0)"
- +11 IF PRCSC=4
- KILL DIC("S")
- +12 SET D="B^C"
- DO MIX^DIC1
- KILL DIC("A"),DIC("B"),DIC("S")
- +13 if Y<0
- QUIT
- +14 SET PRC("CP")=$PIECE(Y(0),U)
- +15 IF PRCIPFLG=1
- DO IP^PRCSUT
- +16 QUIT
- PRT ;REQUESTS TO BE APPROVED LIST
- +1 DO EN3^PRCSUT
- +2 if '$DATA(PRC("SITE"))
- GOTO W2^PRCSEB
- +3 if Y<0
- GOTO END
- +4 SET L=0
- SET DIC="^PRCS(410,"
- +5 SET FLDS="[PRCS REQUESTS FOR APPROVAL]"
- +6 SET BY="'55"
- +7 SET (FR,TO)=""
- +8 SET DIS(0)="I $D(^PRCS(410,D0,0)),$P($G(^PRCS(410,D0,0)),""-"")=PRC(""SITE""),$P(^(0),""-"",4)=$P(PRC(""CP""),"" ""),$P($G(^PRCS(410,D0,1)),U,2)="""""
- +9 DO EN1^DIP
- +10 READ !,"Press return to continue or uparrow to exit: ",X:DTIME,!
- +11 if ('$TEST)!(X'="")
- QUIT
- +12 GOTO PRT
- END QUIT
- RL ;RENUMBER LINE ITEMS
- +1 KILL I
- +2 IF $DATA(^PRCS(410,DA,"IT",0))
- KILL ^("AB"),^("B")
- SET Z=0
- FOR I=1:1
- SET Z=$ORDER(^PRCS(410,DA,"IT",Z))
- if Z'>0
- QUIT
- SET L=^(Z,0)
- SET ^(0)=I_U_$PIECE(^(0),U,2,99)
- SET ^PRCS(410,DA,"IT","B",I,Z)=""
- SET ^PRCS(410,DA,"IT","AB",I,Z)=""
- +3 SET I=$SELECT($DATA(I):I-1,1:0)
- +4 SET ^PRCS(410,DA,10)=$SELECT($DATA(^PRCS(410,DA,10)):I_U_$PIECE(^(10),U,2,99),1:I)
- +5 KILL I,L,Z
- +6 QUIT
- RLR ;RENUMBER LINE ITEMS IN REP ITEM LIST FILE
- +1 KILL I,L
- +2 if '$DATA(^PRCS(410.3,D0,1,0))
- QUIT
- +3 KILL ^("AC"),^("B")
- +4 SET (PRCSCS,Z)=0
- +5 FOR I=1:1
- SET Z=$ORDER(^PRCS(410.3,D0,1,Z))
- if Z'>0
- QUIT
- SET L(I)=^(Z,0)
- KILL ^PRCS(410.3,D0,1,Z,0)
- +6 KILL Z
- +7 SET I=0
- +8 FOR J=1:1
- SET I=$ORDER(L(I))
- if I'>0
- QUIT
- SET Z=L(I)
- SET ^PRCS(410.3,D0,1,J,0)=+Z_U_$PIECE(Z,U,2,99)
- SET PRCSCS=PRCSCS+($PIECE(Z,U,2)*$PIECE(Z,U,4))
- SET ^PRCS(410.3,D0,1,"AC",$PIECE(Z,U,3),I)=""
- SET ^PRCS(410.3,D0,1,"B",+Z,I)=""
- +9 SET $PIECE(^PRCS(410.3,D0,1,0),U,3,4)=(J-1)_U_(J-1)
- SET $PIECE(^PRCS(410.3,D0,0),U,2)=PRCSCS
- +10 KILL I,L,PRCSCS,Z
- +11 QUIT