- PRCSED ;WISC/SAW-CONTROL POINT ACTIVITY EDITS CON'T ;10-30-91/11:32
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- REP ;ENTER REP REQUEST
- D EN^PRCSUT G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0)
- D EN1^PRCSUT3 G:'X EXIT S X1=X D EN2^PRCSUT3 G:'$D(X1) EXIT S X=X1 D W L +^PRCS(410,DA):15 G REP:$T=0 S DIC(0)="AEMQ",DIE=DIC,DR="3///3",X4=3 D ^DIE
- S T1=DA,(PRCSDR,DR)="[PRCSENPR]"
- R1 K DTOUT,DUOUT,Y D ^DIE I $D(Y)!($D(DTOUT)) S DA=T1 L -^PRCS(410,DA) G EXIT
- S DA=T1 D RL^PRCSUT1 L -^PRCS(410,DA)
- D ^PRCSCK I $D(PRCSERR),PRCSERR G R1
- D W1^PRCSEB,W3 G EXIT:%'=1 W !! G REP
- NREP ;ENTER NON-REP REQUEST
- D EN^PRCSUT G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0)
- D EN1^PRCSUT3 Q:'X S X1=X D EN2^PRCSUT3 Q:'$D(X1) S X=X1 D W L +^PRCS(410,DA):15 G NREP:$T=0 S DIC(0)="AEMQ",DIE=DIC,DR="3///2",X4=2 D ^DIE
- S T1=DA,(PRCSDR,DR)="[PRCSEN2237B]"
- N1 K DTOUT,DUOUT,Y D ^DIE I $D(Y)!($D(DTOUT)) S DA=T1 L -^PRCS(410,DA) G EXIT
- S DA=T1 D RL^PRCSUT1
- D ^PRCSCK I $D(PRCSERR),PRCSERR G N1
- D W1^PRCSEB L -^PRCS(410,DA) D W3 G EXIT:%'=1 W !! G NREP
- ;
- ;P182 -- Deleted R1358 SUBROUTINE (not called from anywhere)
- ;
- ACSCP ;ASSIGN CEILING TO SCP'S
- D EN3^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0
- S DIC="^PRCS(410,",DIE=DIC,DIC(0)="AEQM",DIC("S")="I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE""),$P(^(0),""^"",2)=""C"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- S DIC("A")="Select CEILING TRANSACTION NUMBER: " D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A") S DA=+Y L +^PRCS(410,DA):15 G ACSCP:$T=0
- ACSCP1 S DR="[PRCSENE]",DIE=DIC D ^DIE
- S PRCST=$S($D(^PRCS(410,DA,4)):$P(^(4),"^",8),1:"")
- S (PRCS,PRCS(1))=0 F I=0:0 S PRCS=$O(^PRCS(410,DA,12,PRCS)) Q:PRCS'>0 S PRCS(1)=PRCS(1)+$P(^(PRCS,0),"^",2)
- I PRCS(1)>PRCST D ACSCP4 W !!,"You have assigned $ ",$J(PRCS(1),0,2)," to your sub-control points.",!,"This is $ ",$J((PRCS(1)-PRCST),0,2)," more than the total ceiling available."
- I PRCS(1)>PRCST W !,"Please re-edit your entries and make the necessary corrections." G ACSCP1
- ACSCP2 I PRCST>PRCS(1) D ACSCP4 W !!,"You still have $ ",$J((PRCST-PRCS(1)),0,2)," available that could be assigned to your",!,"sub-control points."
- I PRCST>PRCS(1) W " Do you want to re-edit your entries" S %=1 D YN^DICN G ACSCP2:%=0,ACSCP1:%=1
- L -^PRCS(410,DA)
- ACSCP3 W !!,"Would you like to assign ceiling to sub-control points from another",!,"ceiling transaction" S %=2 D YN^DICN G ACSCP3:%=0,ACSCP:%=1,EXIT
- ACSCP4 W !!,"The transaction $ amount is $ ",$S(PRCST:$J(PRCST,0,2),1:"0.00"),"." Q
- SCPC ;CHECK $AMT ASSIGNED TO SCP FOR ADJ AND OBL TRANS
- S DR="[PRCSENE]",(DIC,DIE)="^PRCS(410," D ^DIE
- SCPC0 S (PRCS,PRCS(1))=0 F I=0:0 S PRCS=$O(^PRCS(410,DA,12,PRCS)) Q:PRCS'>0 S PRCS(1)=PRCS(1)+$P(^(PRCS,0),"^",2)
- S (PRCST(1),PRCS(2))=0,PRCST=$S($D(^PRCS(410,DA,4)):$P(^(4),"^",8),1:"") ;I $D(^PRCS(410,DA,0)) I $P(^(0),U,2)="A" S PRCST=$P(^(4),U,6)
- S PRCS(2)=PRCS(1),PRCST(1)=PRCST S:PRCS(1)["-"&(PRCST(1)["-") PRCS(2)=-PRCS(1),PRCST(1)=-PRCST
- I PRCS(2)>PRCST(1) D SCPC2 W !!,"You have assigned $",$J(PRCS(1),0,2)," to your sub-control points.",!,"This is $",$J((PRCS(1)-PRCST),0,2)," more than the total available."
- I PRCS(2)>PRCST(1) W !,"Please re-edit your entries and make the necessary corrections." G SCPC
- SCPC1 I PRCST(1)>PRCS(2) D SCPC2 W !!,"You still have $ ",$J((PRCST-PRCS(1)),0,2)," available that could be assigned to your",!,"sub-control points."
- I PRCST(1)>PRCS(2) W " Do you want to re-edit your entries" S %=1 D YN^DICN G SCPC1:%=0,SCPC:%=1
- G EXIT
- SCPC2 W !!,"The transaction $ amount is $ ",$S(PRCST:$J(PRCST,0,2),1:"0.00"),"." Q
- W W !!,"This transaction is assigned transaction number: ",X Q
- W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT
- W3 W !!,"Would you like to enter another request" S %=1 D YN^DICN G W3:%=0 Q
- EXIT K %,DIC,DIE,DR,PRCSL,PRCST,T1,X,X1,X4 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSED 3966 printed Mar 13, 2025@21:22:24 Page 2
- PRCSED ;WISC/SAW-CONTROL POINT ACTIVITY EDITS CON'T ;10-30-91/11:32
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- REP ;ENTER REP REQUEST
- +1 DO EN^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W2
- if '$DATA(PRC("QTR"))!(Y<0)
- GOTO EXIT
- +2 DO EN1^PRCSUT3
- if 'X
- GOTO EXIT
- SET X1=X
- DO EN2^PRCSUT3
- if '$DATA(X1)
- GOTO EXIT
- SET X=X1
- DO W
- LOCK +^PRCS(410,DA):15
- if $TEST=0
- GOTO REP
- SET DIC(0)="AEMQ"
- SET DIE=DIC
- SET DR="3///3"
- SET X4=3
- DO ^DIE
- +3 SET T1=DA
- SET (PRCSDR,DR)="[PRCSENPR]"
- R1 KILL DTOUT,DUOUT,Y
- DO ^DIE
- IF $DATA(Y)!($DATA(DTOUT))
- SET DA=T1
- LOCK -^PRCS(410,DA)
- GOTO EXIT
- +1 SET DA=T1
- DO RL^PRCSUT1
- LOCK -^PRCS(410,DA)
- +2 DO ^PRCSCK
- IF $DATA(PRCSERR)
- IF PRCSERR
- GOTO R1
- +3 DO W1^PRCSEB
- DO W3
- if %'=1
- GOTO EXIT
- WRITE !!
- GOTO REP
- NREP ;ENTER NON-REP REQUEST
- +1 DO EN^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W2
- if '$DATA(PRC("QTR"))!(Y<0)
- GOTO EXIT
- +2 DO EN1^PRCSUT3
- if 'X
- QUIT
- SET X1=X
- DO EN2^PRCSUT3
- if '$DATA(X1)
- QUIT
- SET X=X1
- DO W
- LOCK +^PRCS(410,DA):15
- if $TEST=0
- GOTO NREP
- SET DIC(0)="AEMQ"
- SET DIE=DIC
- SET DR="3///2"
- SET X4=2
- DO ^DIE
- +3 SET T1=DA
- SET (PRCSDR,DR)="[PRCSEN2237B]"
- N1 KILL DTOUT,DUOUT,Y
- DO ^DIE
- IF $DATA(Y)!($DATA(DTOUT))
- SET DA=T1
- LOCK -^PRCS(410,DA)
- GOTO EXIT
- +1 SET DA=T1
- DO RL^PRCSUT1
- +2 DO ^PRCSCK
- IF $DATA(PRCSERR)
- IF PRCSERR
- GOTO N1
- +3 DO W1^PRCSEB
- LOCK -^PRCS(410,DA)
- DO W3
- if %'=1
- GOTO EXIT
- WRITE !!
- GOTO NREP
- +4 ;
- +5 ;P182 -- Deleted R1358 SUBROUTINE (not called from anywhere)
- +6 ;
- ACSCP ;ASSIGN CEILING TO SCP'S
- +1 DO EN3^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W2
- if Y<0
- GOTO EXIT
- +2 SET DIC="^PRCS(410,"
- SET DIE=DIC
- SET DIC(0)="AEQM"
- SET DIC("S")="I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE""),$P(^(0),""^"",2)=""C"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- +3 SET DIC("A")="Select CEILING TRANSACTION NUMBER: "
- DO ^PRCSDIC
- if Y<0
- GOTO EXIT
- KILL DIC("S"),DIC("A")
- SET DA=+Y
- LOCK +^PRCS(410,DA):15
- if $TEST=0
- GOTO ACSCP
- ACSCP1 SET DR="[PRCSENE]"
- SET DIE=DIC
- DO ^DIE
- +1 SET PRCST=$SELECT($DATA(^PRCS(410,DA,4)):$PIECE(^(4),"^",8),1:"")
- +2 SET (PRCS,PRCS(1))=0
- FOR I=0:0
- SET PRCS=$ORDER(^PRCS(410,DA,12,PRCS))
- if PRCS'>0
- QUIT
- SET PRCS(1)=PRCS(1)+$PIECE(^(PRCS,0),"^",2)
- +3 IF PRCS(1)>PRCST
- DO ACSCP4
- WRITE !!,"You have assigned $ ",$JUSTIFY(PRCS(1),0,2)," to your sub-control points.",!,"This is $ ",$JUSTIFY((PRCS(1)-PRCST),0,2)," more than the total ceiling available."
- +4 IF PRCS(1)>PRCST
- WRITE !,"Please re-edit your entries and make the necessary corrections."
- GOTO ACSCP1
- ACSCP2 IF PRCST>PRCS(1)
- DO ACSCP4
- WRITE !!,"You still have $ ",$JUSTIFY((PRCST-PRCS(1)),0,2)," available that could be assigned to your",!,"sub-control points."
- +1 IF PRCST>PRCS(1)
- WRITE " Do you want to re-edit your entries"
- SET %=1
- DO YN^DICN
- if %=0
- GOTO ACSCP2
- if %=1
- GOTO ACSCP1
- +2 LOCK -^PRCS(410,DA)
- ACSCP3 WRITE !!,"Would you like to assign ceiling to sub-control points from another",!,"ceiling transaction"
- SET %=2
- DO YN^DICN
- if %=0
- GOTO ACSCP3
- if %=1
- GOTO ACSCP
- GOTO EXIT
- ACSCP4 WRITE !!,"The transaction $ amount is $ ",$SELECT(PRCST:$JUSTIFY(PRCST,0,2),1:"0.00"),"."
- QUIT
- SCPC ;CHECK $AMT ASSIGNED TO SCP FOR ADJ AND OBL TRANS
- +1 SET DR="[PRCSENE]"
- SET (DIC,DIE)="^PRCS(410,"
- DO ^DIE
- SCPC0 SET (PRCS,PRCS(1))=0
- FOR I=0:0
- SET PRCS=$ORDER(^PRCS(410,DA,12,PRCS))
- if PRCS'>0
- QUIT
- SET PRCS(1)=PRCS(1)+$PIECE(^(PRCS,0),"^",2)
- +1 ;I $D(^PRCS(410,DA,0)) I $P(^(0),U,2)="A" S PRCST=$P(^(4),U,6)
- SET (PRCST(1),PRCS(2))=0
- SET PRCST=$SELECT($DATA(^PRCS(410,DA,4)):$PIECE(^(4),"^",8),1:"")
- +2 SET PRCS(2)=PRCS(1)
- SET PRCST(1)=PRCST
- if PRCS(1)["-"&(PRCST(1)["-")
- SET PRCS(2)=-PRCS(1)
- SET PRCST(1)=-PRCST
- +3 IF PRCS(2)>PRCST(1)
- DO SCPC2
- WRITE !!,"You have assigned $",$JUSTIFY(PRCS(1),0,2)," to your sub-control points.",!,"This is $",$JUSTIFY((PRCS(1)-PRCST),0,2)," more than the total available."
- +4 IF PRCS(2)>PRCST(1)
- WRITE !,"Please re-edit your entries and make the necessary corrections."
- GOTO SCPC
- SCPC1 IF PRCST(1)>PRCS(2)
- DO SCPC2
- WRITE !!,"You still have $ ",$JUSTIFY((PRCST-PRCS(1)),0,2)," available that could be assigned to your",!,"sub-control points."
- +1 IF PRCST(1)>PRCS(2)
- WRITE " Do you want to re-edit your entries"
- SET %=1
- DO YN^DICN
- if %=0
- GOTO SCPC1
- if %=1
- GOTO SCPC
- +2 GOTO EXIT
- SCPC2 WRITE !!,"The transaction $ amount is $ ",$SELECT(PRCST:$JUSTIFY(PRCST,0,2),1:"0.00"),"."
- QUIT
- W WRITE !!,"This transaction is assigned transaction number: ",X
- QUIT
- W2 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
- READ X:5
- GOTO EXIT
- W3 WRITE !!,"Would you like to enter another request"
- SET %=1
- DO YN^DICN
- if %=0
- GOTO W3
- QUIT
- EXIT KILL %,DIC,DIE,DR,PRCSL,PRCST,T1,X,X1,X4
- QUIT
