- PRCSRIE1 ;WISC/SAW/DXH/SC/BMM - DELETE/REPLACE REPETITIVE ITEM LIST ; 3/31/05 3:22pm
- V ;;5.1;IFCAP;**13,81**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;BMM patch PRC*5.1*81 in EDIT, added DMCHK to ensure RILs from
- ;DynaMed are not edited. First check that DynaMed switch is on.
- ;*81-SC-if it is DM RIL trx, then right before deleting update Audit
- ;File 414.02 & send a msg to DynaMed thru a call to rtn PRCVRCA.
- ;
- EDIT ;EDIT REP ITEM
- D DISP^PRCOSS3
- S DIC="^PRCS(410.3,",DIC(0)="AEMQZ",DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- S DIC("A")="Select REPETITIVE ITEM LIST #: " D ^DIC K DIC("S") I Y'>0 G EXIT
- S (PRCSDA,DA)=+Y,PRCSNO=$P(^PRCS(410.3,DA,0),U)
- ;PRC*5.1*81 can't edit if DynaMed RIL
- I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q"),$$DMCHK(DA) W !!,"** This RIL originated from DynaMed and cannot be edited **" H 3 G EXIT
- L +^PRCS(410.3,DA):1
- I $T=0 W !!,?15,"** Record in use, try to edit later **",! G EDIT
- S PRC("SITE")=+Y(0),PRC("CP")=$P(Y(0),"-",4),DR="[PRCSRI]",DIE=DIC,DIE("NO^")=1 D ^DIE D CALC L -^PRCS(410.3,DA) K DIE("NO^")
- W2 W !!,"Would you like to edit another repetitive item list entry" S %=2 D YN^DICN G W2:%=0,EXIT:%=2!(%<1) W !! K PRCSV,PRCSV1 G EDIT
- CALC ;CALCULATE TOTAL COST
- W !,"Let me total the cost for this Repetitive Item List entry (#",PRCSNO,")"
- S (N,PRCSTC)="" F I=0:1 S N=$O(^PRCS(410.3,PRCSDA,1,"B",N)) Q:N="" S N(1)="",N(1)=$O(^(N,N(1))) I $D(^PRCS(410.3,PRCSDA,1,N(1),0)) S N(2)=^(0),PRCSTC=PRCSTC+($P(N(2),"^",2)*($P(N(2),"^",4)))
- W !,"Total number of items: ",I," Total cost (all items): $",$J(PRCSTC,0,2) S $P(^PRCS(410.3,PRCSDA,0),"^",2)=PRCSTC K N,PRCSTC
- ;Karen's new stuff
- CHECK ;
- S ZIP=0 F S ZIP=$O(^PRCS(410.3,PRCSDA,1,ZIP)) Q:+ZIP=0 D
- .S K0=^PRCS(410.3,PRCSDA,1,ZIP,0),V0=$P(K0,"^",5),V1=$P(K0,"^")
- .S K1=$P($G(^PRC(441,+V1,2,+V0,0)),"^",3) S:K1'="" $P(K0,"^",6)="Y" S:K1="" $P(K0,"^",6)="N"
- .S ^PRCS(410.3,PRCSDA,1,ZIP,0)=K0
- K ZIP,K0,K1,V0,V1 QUIT
- DEL ;DELETE REPETITIVE ITEM LIST ENTRY
- S DIC="^PRCS(410.3,",DIC(0)="AEMQZ",DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=+$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- S DIC("A")="Select REPETITIVE ITEM LIST #: " D ^DIC K DIC("S") I Y'>0 G EXIT
- S DA=+Y L +^PRCS(410.3,DA):1
- I $T=0 W !!,?15,"** Record in use, try to delete later **",! G DEL
- DEL1 W !,"Are you sure you want to delete this Repetitive Item List entry" S %=2 D YN^DICN G DEL1:%=0 I %<0!(%=2) L -^PRCS(410.3,DA) G EXIT
- ;PRC*5.1*81 if it is DM RIL, then update Audit File & send msg to DM
- S DIK=DIC D EN^PRCVRCA(DA) L -^PRCS(410.3,DA) W !,"Okay....." D ^DIK W "It's deleted."
- DEL2 W !,"Would you like to delete another Repetitive Item List entry" S %=2 D YN^DICN G DEL2:%=0,EXIT:%=2,EXIT:%<0 W !! G DEL
- REPL ;REPLACE EXISTING REPETITIVE ITEM LIST ENTRY NUMBER
- W !!,"Select the existing Repetitive Item List entry number to be replaced.",!
- S DIC="^PRCS(410.3,",DIC(0)="AEMQZ",DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- S DIC("A")="Select REPETITIVE ITEM LIST #: " D ^DIC K DIC("S") I Y'>0 G EXIT
- S DA=+Y L +^PRCS(410.3):15 G:$T=0 REPL
- S T1=+Y,T2=$P(Y(0),"^"),PRC("SITE")=+^PRCS(410.3,DA,0),PRC("CP")=$P(^(0),"-",4) K DA,DIC,Y
- W !!,"Now enter the information for the new Repetitive Item List entry number.",!
- D EN^PRCSUT G W5^PRCSUT3:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0)
- K ^PRCS(410.3,"B",T2,T1),^PRCS(410.3,"C",$P(T2,"-",5),T1)
- I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)>1 S Y="NONE" G STF
- S DIC="^PRC(420,PRC(""SITE""),1,+PRC(""CP""),2,",DIC(0)="AEMNQZ" D ^DIC I Y'>0 G EXIT
- S Y=$P(Y(0),"^") I '$D(^PRCD(420.1,Y,0)) G EXIT
- STF S X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")_"-"_Y
- S $P(^PRCS(410.3,T1,0),"^")=X,^PRCS(410.3,"B",X,T1)="",^PRCS(410.3,"C",Y,T1)=""
- L -^PRCS(410.3)
- REPL1 W !!,"Would you like to replace another Repetitive Item List entry number" S %=2 D YN^DICN G REPL1:%=0,EXIT:%<0,EXIT:%=2 I %=1 W !! G REPL
- SUB ;ASK BOC IF ONE DOES NOT EXIST FOR ITEM IN FILE 441
- S Z0=$P(^PRCS(410.3,DA(1),1,DA,0),"^"),DIC="^PRCD(420.2,",DIC(0)="AEMQ",DIC("A")="Select BOC: "
- SUB1 D ^DIC I Y'>0 W !,$C(7),"Sorry, but you must select a budget object code for this item." G SUB1
- S $P(^PRC(441,Z0,0),"^",10)=+Y S DIC=DIE K Y,Z0 Q
- VENDORH ;HELP PROMPT FOR VENDOR FIELD IN FILE 410.3
- S:$D(D) ZD=D S X="?",Z0=$P(^PRCS(410.3,DA(1),1,DA,0),"^") Q:'Z0 Q:'$D(^PRC(441,Z0,2,0))
- S DIC="^PRC(441,Z0,2,",DIC(0)="QEM" S:$G(PRCSIP) DIC("S")="I $O(^PRCP(445,PRCSIP,1,Z0,5,""B"",(+Y_"";PRC(440,""),0))" D ^DIC S DIC=DIE S:$D(ZD) D=ZD K ZD,DIC("S") Q
- EXIT K %,DA,DIC,DIE,DR,PRCSL,T1,T2,X,Y Q
- ;
- DMCHK(DA) ;check that RIL is not from DynaMed, set flag
- ;DA is RIL IEN in file 410.3
- ;
- N PRCVD,PRCVFG S (PRCVD,PRCVFG)=0
- D1 S PRCVD=$O(^PRCS(410.3,DA,1,PRCVD)) G:+PRCVD=0 D2
- I $$GET1^DIQ(410.31,PRCVD_","_DA_",",6)'="" S PRCVFG=1 G D2
- G D1
- D2 Q PRCVFG
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSRIE1 5165 printed Feb 18, 2025@23:44:48 Page 2
- PRCSRIE1 ;WISC/SAW/DXH/SC/BMM - DELETE/REPLACE REPETITIVE ITEM LIST ; 3/31/05 3:22pm
- V ;;5.1;IFCAP;**13,81**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- +3 ;BMM patch PRC*5.1*81 in EDIT, added DMCHK to ensure RILs from
- +4 ;DynaMed are not edited. First check that DynaMed switch is on.
- +5 ;*81-SC-if it is DM RIL trx, then right before deleting update Audit
- +6 ;File 414.02 & send a msg to DynaMed thru a call to rtn PRCVRCA.
- +7 ;
- EDIT ;EDIT REP ITEM
- +1 DO DISP^PRCOSS3
- +2 SET DIC="^PRCS(410.3,"
- SET DIC(0)="AEMQZ"
- SET DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- +3 SET DIC("A")="Select REPETITIVE ITEM LIST #: "
- DO ^DIC
- KILL DIC("S")
- IF Y'>0
- GOTO EXIT
- +4 SET (PRCSDA,DA)=+Y
- SET PRCSNO=$PIECE(^PRCS(410.3,DA,0),U)
- +5 ;PRC*5.1*81 can't edit if DynaMed RIL
- +6 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
- IF $$DMCHK(DA)
- WRITE !!,"** This RIL originated from DynaMed and cannot be edited **"
- HANG 3
- GOTO EXIT
- +7 LOCK +^PRCS(410.3,DA):1
- +8 IF $TEST=0
- WRITE !!,?15,"** Record in use, try to edit later **",!
- GOTO EDIT
- +9 SET PRC("SITE")=+Y(0)
- SET PRC("CP")=$PIECE(Y(0),"-",4)
- SET DR="[PRCSRI]"
- SET DIE=DIC
- SET DIE("NO^")=1
- DO ^DIE
- DO CALC
- LOCK -^PRCS(410.3,DA)
- KILL DIE("NO^")
- W2 WRITE !!,"Would you like to edit another repetitive item list entry"
- SET %=2
- DO YN^DICN
- if %=0
- GOTO W2
- if %=2!(%<1)
- GOTO EXIT
- WRITE !!
- KILL PRCSV,PRCSV1
- GOTO EDIT
- CALC ;CALCULATE TOTAL COST
- +1 WRITE !,"Let me total the cost for this Repetitive Item List entry (#",PRCSNO,")"
- +2 SET (N,PRCSTC)=""
- FOR I=0:1
- SET N=$ORDER(^PRCS(410.3,PRCSDA,1,"B",N))
- if N=""
- QUIT
- SET N(1)=""
- SET N(1)=$ORDER(^(N,N(1)))
- IF $DATA(^PRCS(410.3,PRCSDA,1,N(1),0))
- SET N(2)=^(0)
- SET PRCSTC=PRCSTC+($PIECE(N(2),"^",2)*($PIECE(N(2),"^",4)))
- +3 WRITE !,"Total number of items: ",I," Total cost (all items): $",$JUSTIFY(PRCSTC,0,2)
- SET $PIECE(^PRCS(410.3,PRCSDA,0),"^",2)=PRCSTC
- KILL N,PRCSTC
- +4 ;Karen's new stuff
- CHECK ;
- +1 SET ZIP=0
- FOR
- SET ZIP=$ORDER(^PRCS(410.3,PRCSDA,1,ZIP))
- if +ZIP=0
- QUIT
- Begin DoDot:1
- +2 SET K0=^PRCS(410.3,PRCSDA,1,ZIP,0)
- SET V0=$PIECE(K0,"^",5)
- SET V1=$PIECE(K0,"^")
- +3 SET K1=$PIECE($GET(^PRC(441,+V1,2,+V0,0)),"^",3)
- if K1'=""
- SET $PIECE(K0,"^",6)="Y"
- if K1=""
- SET $PIECE(K0,"^",6)="N"
- +4 SET ^PRCS(410.3,PRCSDA,1,ZIP,0)=K0
- End DoDot:1
- +5 KILL ZIP,K0,K1,V0,V1
- QUIT
- DEL ;DELETE REPETITIVE ITEM LIST ENTRY
- +1 SET DIC="^PRCS(410.3,"
- SET DIC(0)="AEMQZ"
- SET DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=+$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- +2 SET DIC("A")="Select REPETITIVE ITEM LIST #: "
- DO ^DIC
- KILL DIC("S")
- IF Y'>0
- GOTO EXIT
- +3 SET DA=+Y
- LOCK +^PRCS(410.3,DA):1
- +4 IF $TEST=0
- WRITE !!,?15,"** Record in use, try to delete later **",!
- GOTO DEL
- DEL1 WRITE !,"Are you sure you want to delete this Repetitive Item List entry"
- SET %=2
- DO YN^DICN
- if %=0
- GOTO DEL1
- IF %<0!(%=2)
- LOCK -^PRCS(410.3,DA)
- GOTO EXIT
- +1 ;PRC*5.1*81 if it is DM RIL, then update Audit File & send msg to DM
- +2 SET DIK=DIC
- DO EN^PRCVRCA(DA)
- LOCK -^PRCS(410.3,DA)
- WRITE !,"Okay....."
- DO ^DIK
- WRITE "It's deleted."
- DEL2 WRITE !,"Would you like to delete another Repetitive Item List entry"
- SET %=2
- DO YN^DICN
- if %=0
- GOTO DEL2
- if %=2
- GOTO EXIT
- if %<0
- GOTO EXIT
- WRITE !!
- GOTO DEL
- REPL ;REPLACE EXISTING REPETITIVE ITEM LIST ENTRY NUMBER
- +1 WRITE !!,"Select the existing Repetitive Item List entry number to be replaced.",!
- +2 SET DIC="^PRCS(410.3,"
- SET DIC(0)="AEMQZ"
- SET DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
- +3 SET DIC("A")="Select REPETITIVE ITEM LIST #: "
- DO ^DIC
- KILL DIC("S")
- IF Y'>0
- GOTO EXIT
- +4 SET DA=+Y
- LOCK +^PRCS(410.3):15
- if $TEST=0
- GOTO REPL
- +5 SET T1=+Y
- SET T2=$PIECE(Y(0),"^")
- SET PRC("SITE")=+^PRCS(410.3,DA,0)
- SET PRC("CP")=$PIECE(^(0),"-",4)
- KILL DA,DIC,Y
- +6 WRITE !!,"Now enter the information for the new Repetitive Item List entry number.",!
- +7 DO EN^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W5^PRCSUT3
- if '$DATA(PRC("QTR"))!(Y<0)
- GOTO EXIT
- +8 KILL ^PRCS(410.3,"B",T2,T1),^PRCS(410.3,"C",$PIECE(T2,"-",5),T1)
- +9 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
- IF $PIECE(^(0),U,12)>1
- SET Y="NONE"
- GOTO STF
- +10 SET DIC="^PRC(420,PRC(""SITE""),1,+PRC(""CP""),2,"
- SET DIC(0)="AEMNQZ"
- DO ^DIC
- IF Y'>0
- GOTO EXIT
- +11 SET Y=$PIECE(Y(0),"^")
- IF '$DATA(^PRCD(420.1,Y,0))
- GOTO EXIT
- STF SET X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")_"-"_Y
- +1 SET $PIECE(^PRCS(410.3,T1,0),"^")=X
- SET ^PRCS(410.3,"B",X,T1)=""
- SET ^PRCS(410.3,"C",Y,T1)=""
- +2 LOCK -^PRCS(410.3)
- REPL1 WRITE !!,"Would you like to replace another Repetitive Item List entry number"
- SET %=2
- DO YN^DICN
- if %=0
- GOTO REPL1
- if %<0
- GOTO EXIT
- if %=2
- GOTO EXIT
- IF %=1
- WRITE !!
- GOTO REPL
- SUB ;ASK BOC IF ONE DOES NOT EXIST FOR ITEM IN FILE 441
- +1 SET Z0=$PIECE(^PRCS(410.3,DA(1),1,DA,0),"^")
- SET DIC="^PRCD(420.2,"
- SET DIC(0)="AEMQ"
- SET DIC("A")="Select BOC: "
- SUB1 DO ^DIC
- IF Y'>0
- WRITE !,$CHAR(7),"Sorry, but you must select a budget object code for this item."
- GOTO SUB1
- +1 SET $PIECE(^PRC(441,Z0,0),"^",10)=+Y
- SET DIC=DIE
- KILL Y,Z0
- QUIT
- VENDORH ;HELP PROMPT FOR VENDOR FIELD IN FILE 410.3
- +1 if $DATA(D)
- SET ZD=D
- SET X="?"
- SET Z0=$PIECE(^PRCS(410.3,DA(1),1,DA,0),"^")
- if 'Z0
- QUIT
- if '$DATA(^PRC(441,Z0,2,0))
- QUIT
- +2 SET DIC="^PRC(441,Z0,2,"
- SET DIC(0)="QEM"
- if $GET(PRCSIP)
- SET DIC("S")="I $O(^PRCP(445,PRCSIP,1,Z0,5,""B"",(+Y_"";PRC(440,""),0))"
- DO ^DIC
- SET DIC=DIE
- if $DATA(ZD)
- SET D=ZD
- KILL ZD,DIC("S")
- QUIT
- EXIT KILL %,DA,DIC,DIE,DR,PRCSL,T1,T2,X,Y
- QUIT
- +1 ;
- DMCHK(DA) ;check that RIL is not from DynaMed, set flag
- +1 ;DA is RIL IEN in file 410.3
- +2 ;
- +3 NEW PRCVD,PRCVFG
- SET (PRCVD,PRCVFG)=0
- D1 SET PRCVD=$ORDER(^PRCS(410.3,DA,1,PRCVD))
- if +PRCVD=0
- GOTO D2
- +1 IF $$GET1^DIQ(410.31,PRCVD_","_DA_",",6)'=""
- SET PRCVFG=1
- GOTO D2
- +2 GOTO D1
- D2 QUIT PRCVFG
- +1 ;