| [613] | 1 | PRCPEGRP ;WISC/RFJ-group categories ;23 Dec 92
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | D ^PRCPUSEL Q:'$G(PRCP("I"))
|
|---|
| 5 | N %,COUNT,D,D0,DA,DIDEL,PRCPPRIV,DI,DIC,DIE,DLAYGO,DQ,DR,EACHONE,GROUP,ITEMDA,LASTONE,PRCPFLAG,PRCPINPT,TOTAL,X,Y
|
|---|
| 6 | S PRCPINPT=PRCP("I")
|
|---|
| 7 | F D Q:$G(PRCPFLAG)
|
|---|
| 8 | . S DIC="^PRCP(445.6,",DIC("S")="I $P(^(0),U,2)=PRCP(""I"")",DIC(0)="QEALM",DLAYGO=445.6,PRCPPRIV=1 W ! D ^DIC I Y'>0 S PRCPFLAG=1 Q
|
|---|
| 9 | . S DIE="^PRCP(445.6,",DR=".01;2",(GROUP,DA)=+Y,DIDEL=445.6 D ^DIE
|
|---|
| 10 | . I '$D(^PRCP(445.6,GROUP,0)) D
|
|---|
| 11 | . . W !!,"<<< Removing this group from all items in the inventory point"
|
|---|
| 12 | . . S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
|
|---|
| 13 | . . S (ITEMDA,TOTAL)=0 F COUNT=1:1 S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) D
|
|---|
| 14 | . . . S LASTONE=$$SHPERCNT^PRCPUX2(COUNT,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
|
|---|
| 15 | . . . I D'="",$P(D,"^",21)=GROUP S $P(^PRCP(445,PRCP("I"),1,ITEMDA,0),"^",21)="",TOTAL=TOTAL+1
|
|---|
| 16 | . . D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
|
|---|
| 17 | . . W !!?10,"Total items with group category removed: ",TOTAL
|
|---|
| 18 | Q
|
|---|
| 19 | ;
|
|---|
| 20 | ;
|
|---|
| 21 | GROUP(INVPT,GROUPDA) ; select group for invpt
|
|---|
| 22 | ; if groupda lookup without asking
|
|---|
| 23 | N DIC,X,Y
|
|---|
| 24 | S DIC="^PRCP(445.6,",DIC("S")="I $P(^(0),U,2)=INVPT",DIC(0)="QEAM",PRCPPRIV=1
|
|---|
| 25 | I $G(GROUPDA)'="" S DIC(0)="M",X=+GROUPDA
|
|---|
| 26 | D ^DIC K PRCPPRIV
|
|---|
| 27 | Q $S($G(X)["^":-1,Y<0:0,1:+Y)
|
|---|
| 28 | ;
|
|---|
| 29 | ;
|
|---|
| 30 | ADDGRP(INVPT,GROUPNM,DESCRIPT) ; add group name, description for invpt
|
|---|
| 31 | N D0,DA,DD,DIC,DLAYGO,DINUM,X,Y
|
|---|
| 32 | S DIC="^PRCP(445.6,",DIC(0)="L",DLAYGO=445.6,X=GROUPNM,DIC("DR")="1///"_INVPT_$S(DESCRIPT'="":";2///"_DESCRIPT,1:""),PRCPPRIV=1
|
|---|
| 33 | D FILE^DICN K PRCPPRIV
|
|---|
| 34 | Q +Y
|
|---|
| 35 | ;
|
|---|
| 36 | ;
|
|---|
| 37 | GROUPNM(GROUPDA) ; return group name for groupda
|
|---|
| 38 | I '$D(^PRCP(445.6,+GROUPDA,0)) Q ""
|
|---|
| 39 | N %
|
|---|
| 40 | S %=^PRCP(445.6,+GROUPDA,0)
|
|---|
| 41 | Q $P(%,"^")_": "_$P(%,"^",3)
|
|---|
| 42 | ;
|
|---|
| 43 | ;
|
|---|
| 44 | GROUPDA(INVPT,ITEMDA) ; return group da for invpt and item
|
|---|
| 45 | Q $P($G(^PRCP(445,+INVPT,1,+ITEMDA,0)),"^",21)
|
|---|
| 46 | ;
|
|---|
| 47 | ;
|
|---|
| 48 | SETGRP(INVPT,ITEMDA,GROUPDA) ; set group for invpt and item
|
|---|
| 49 | I '$D(^PRCP(445,+INVPT,1,+ITEMDA,0)) Q
|
|---|
| 50 | I '$D(^PRCP(445.6,+GROUPDA,0)) Q
|
|---|
| 51 | S $P(^PRCP(445,+INVPT,1,+ITEMDA,0),"^",21)=GROUPDA
|
|---|
| 52 | Q
|
|---|
