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 Dec 13, 2024@02:19:08 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
