PRCPEGRP ;WISC/RFJ-group categories ;23 Dec 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N %,COUNT,D,D0,DA,DIDEL,PRCPPRIV,DI,DIC,DIE,DLAYGO,DQ,DR,EACHONE,GROUP,ITEMDA,LASTONE,PRCPFLAG,PRCPINPT,TOTAL,X,Y
S PRCPINPT=PRCP("I")
F D Q:$G(PRCPFLAG)
. 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
. S DIE="^PRCP(445.6,",DR=".01;2",(GROUP,DA)=+Y,DIDEL=445.6 D ^DIE
. I '$D(^PRCP(445.6,GROUP,0)) D
. . W !!,"<<< Removing this group from all items in the inventory point"
. . S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
. . 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
. . . S LASTONE=$$SHPERCNT^PRCPUX2(COUNT,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
. . . I D'="",$P(D,"^",21)=GROUP S $P(^PRCP(445,PRCP("I"),1,ITEMDA,0),"^",21)="",TOTAL=TOTAL+1
. . D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
. . W !!?10,"Total items with group category removed: ",TOTAL
Q
;
;
GROUP(INVPT,GROUPDA) ; select group for invpt
; if groupda lookup without asking
N DIC,X,Y
S DIC="^PRCP(445.6,",DIC("S")="I $P(^(0),U,2)=INVPT",DIC(0)="QEAM",PRCPPRIV=1
I $G(GROUPDA)'="" S DIC(0)="M",X=+GROUPDA
D ^DIC K PRCPPRIV
Q $S($G(X)["^":-1,Y<0:0,1:+Y)
;
;
ADDGRP(INVPT,GROUPNM,DESCRIPT) ; add group name, description for invpt
N D0,DA,DD,DIC,DLAYGO,DINUM,X,Y
S DIC="^PRCP(445.6,",DIC(0)="L",DLAYGO=445.6,X=GROUPNM,DIC("DR")="1///"_INVPT_$S(DESCRIPT'="":";2///"_DESCRIPT,1:""),PRCPPRIV=1
D FILE^DICN K PRCPPRIV
Q +Y
;
;
GROUPNM(GROUPDA) ; return group name for groupda
I '$D(^PRCP(445.6,+GROUPDA,0)) Q ""
N %
S %=^PRCP(445.6,+GROUPDA,0)
Q $P(%,"^")_": "_$P(%,"^",3)
;
;
GROUPDA(INVPT,ITEMDA) ; return group da for invpt and item
Q $P($G(^PRCP(445,+INVPT,1,+ITEMDA,0)),"^",21)
;
;
SETGRP(INVPT,ITEMDA,GROUPDA) ; set group for invpt and item
I '$D(^PRCP(445,+INVPT,1,+ITEMDA,0)) Q
I '$D(^PRCP(445.6,+GROUPDA,0)) Q
S $P(^PRCP(445,+INVPT,1,+ITEMDA,0),"^",21)=GROUPDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPEGRP 2293 printed Oct 16, 2024@18:14:17 Page 2
PRCPEGRP ;WISC/RFJ-group categories ;23 Dec 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 NEW %,COUNT,D,D0,DA,DIDEL,PRCPPRIV,DI,DIC,DIE,DLAYGO,DQ,DR,EACHONE,GROUP,ITEMDA,LASTONE,PRCPFLAG,PRCPINPT,TOTAL,X,Y
+5 SET PRCPINPT=PRCP("I")
+6 FOR
Begin DoDot:1
+7 SET DIC="^PRCP(445.6,"
SET DIC("S")="I $P(^(0),U,2)=PRCP(""I"")"
SET DIC(0)="QEALM"
SET DLAYGO=445.6
SET PRCPPRIV=1
WRITE !
DO ^DIC
IF Y'>0
SET PRCPFLAG=1
QUIT
+8 SET DIE="^PRCP(445.6,"
SET DR=".01;2"
SET (GROUP,DA)=+Y
SET DIDEL=445.6
DO ^DIE
+9 IF '$DATA(^PRCP(445.6,GROUP,0))
Begin DoDot:2
+10 WRITE !!,"<<< Removing this group from all items in the inventory point"
+11 SET EACHONE=$$INPERCNT^PRCPUX2(+$PIECE($GET(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
+12 SET (ITEMDA,TOTAL)=0
FOR COUNT=1:1
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET D=$GET(^(ITEMDA,0))
Begin DoDot:3
+13 SET LASTONE=$$SHPERCNT^PRCPUX2(COUNT,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
+14 IF D'=""
IF $PIECE(D,"^",21)=GROUP
SET $PIECE(^PRCP(445,PRCP("I"),1,ITEMDA,0),"^",21)=""
SET TOTAL=TOTAL+1
End DoDot:3
+15 DO QPERCNT^PRCPUX2(+$GET(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
+16 WRITE !!?10,"Total items with group category removed: ",TOTAL
End DoDot:2
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+17 QUIT
+18 ;
+19 ;
GROUP(INVPT,GROUPDA) ; select group for invpt
+1 ; if groupda lookup without asking
+2 NEW DIC,X,Y
+3 SET DIC="^PRCP(445.6,"
SET DIC("S")="I $P(^(0),U,2)=INVPT"
SET DIC(0)="QEAM"
SET PRCPPRIV=1
+4 IF $GET(GROUPDA)'=""
SET DIC(0)="M"
SET X=+GROUPDA
+5 DO ^DIC
KILL PRCPPRIV
+6 QUIT $SELECT($GET(X)["^":-1,Y<0:0,1:+Y)
+7 ;
+8 ;
ADDGRP(INVPT,GROUPNM,DESCRIPT) ; add group name, description for invpt
+1 NEW D0,DA,DD,DIC,DLAYGO,DINUM,X,Y
+2 SET DIC="^PRCP(445.6,"
SET DIC(0)="L"
SET DLAYGO=445.6
SET X=GROUPNM
SET DIC("DR")="1///"_INVPT_$SELECT(DESCRIPT'="":";2///"_DESCRIPT,1:"")
SET PRCPPRIV=1
+3 DO FILE^DICN
KILL PRCPPRIV
+4 QUIT +Y
+5 ;
+6 ;
GROUPNM(GROUPDA) ; return group name for groupda
+1 IF '$DATA(^PRCP(445.6,+GROUPDA,0))
QUIT ""
+2 NEW %
+3 SET %=^PRCP(445.6,+GROUPDA,0)
+4 QUIT $PIECE(%,"^")_": "_$PIECE(%,"^",3)
+5 ;
+6 ;
GROUPDA(INVPT,ITEMDA) ; return group da for invpt and item
+1 QUIT $PIECE($GET(^PRCP(445,+INVPT,1,+ITEMDA,0)),"^",21)
+2 ;
+3 ;
SETGRP(INVPT,ITEMDA,GROUPDA) ; set group for invpt and item
+1 IF '$DATA(^PRCP(445,+INVPT,1,+ITEMDA,0))
QUIT
+2 IF '$DATA(^PRCP(445.6,+GROUPDA,0))
QUIT
+3 SET $PIECE(^PRCP(445,+INVPT,1,+ITEMDA,0),"^",21)=GROUPDA
+4 QUIT
