PRCPHLUT ;WISC/CC-Process activity information from file 447.1 ;4/00
V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
PROCESS(PRCPDA,PRCPDONE) ;
N %,ERR,ITEM,ITEMDATA,PRCPAMT,PRCPDATA,PRCPHLUT,PRCPITDA
N PRCPITEM,PRCPITNM,PRCPLEFT,PRCPREAS,PRCPREC,PRCPSEC,PRCPSSFL,PRCPTIME
N PRCPUSER,TRANORDR,TYPE
;
S PRCPDONE=0
S PRCPDATA=^PRCP(447.1,PRCPDA,0)
S PRCPHL7=$P(PRCPDATA,"^",6)_".447.1"
S PRCPSEC=$P(PRCPDATA,"^",3)
S PRCPTIME=$P(PRCPDATA,"^",8)
S PRCPREC=$P(PRCPDATA,"^",9)
S PRCPUSER=$P(PRCPDATA,"^",10)
S PRCPREAS=$P(PRCPDATA,"^",11)
S PRCPACTV=$P(PRCPREAS,"~",1)
;
S PRCPITDA=0
S PRCPITDA=$O(^PRCP(447.1,PRCPDA,1,PRCPITDA)) I '+PRCPITDA S ERR="6F" G ERR ; no item info
S PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
S PRCPAMT=$P(PRCPDATA,"^",3) ; REFILL QTY - patient issue units
I PRCPACTV="USGE"!(PRCPACTV="DISP")!(PRCPACTV="ADJD") S PRCPAMT=-PRCPAMT
S PRCPITEM=$P(PRCPDATA,"^",1)
S PRCPITNM=$P(PRCPDATA,"^",4)
S PRCPLEFT=$P(PRCPDATA,"^",2) ; patient issue units
;
I '$D(^PRCP(445,PRCPSEC)) S ERR="3A" G ERR ; secondary not in GIP
I $P(^PRCP(445,PRCPSEC,0),"^",3)'="S" S ERR="3B" G ERR ; not a secondary
I '$D(^PRCP(445,PRCPSEC,1,PRCPITEM)) S ERR="6C" G ERR
I $P(^PRCP(445,PRCPSEC,1,PRCPITEM,0),"^",9)'>0 S ERR="6D" G ERR ; is item a supply station item?
I $P($G(^PRCP(445,PRCPSEC,5)),"^",1)']"" S ERR="3F" G ERR ; not a supply station secondary
; compare name in 445 to name sent, CONTINUE
S PRCPSSFL=$P(^PRCP(445.5,$P(^PRCP(445,PRCPSEC,5),"^",1),0),"^",2)
I PRCPSSFL="O",$P(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
I PRCPSSFL="S",$G(^PRCP(445,PRCPSEC,1,PRCPITEM,6))'=PRCPITNM D NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
;
UPDATE S ITEMDATA=$G(^PRCP(445,PRCPSEC,1,PRCPITEM,0))
I ITEMDATA="" S ERR="6C" G ERR ; send message
S TYPE="U"
I $E($P(PRCPREAS,"~",1),1,3)="ADJ"!($P(PRCPREAS,"~")="DISP") S TYPE="A"
S PRCPHLUT("INVVAL")=$J(PRCPAMT*$P(ITEMDATA,"^",22),0,2)
S PRCPHLUT("DATE")=PRCPTIME
S PRCPHLUT("ITEM")=ITEMDATA
S PRCPHLUT("REASON")=$P(PRCPREAS,"~",1)_":"_$P(PRCPREAS,"~",2)
S PRCPHLUT("RECIPIENT")=$TR(PRCPREC,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S PRCPHLUT("USER")=PRCPUSER
S PRCPHLUT("SELVAL")=PRCPHLUT("INVVAL")
S PRCPHLUT("QTY")=PRCPAMT
;
; save values into GIP files
D UPDATE^PRCPHL1(PRCPSEC,PRCPITEM,PRCPLEFT,.PRCPHLUT,TYPE)
;
; check expected qty remaining
S ITEMDATA=$G(^PRCP(445,PRCPSEC,1,PRCPITEM,0))
I $P(ITEMDATA,"^",7)'=PRCPLEFT D
. D QTYDISC^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,$P(ITEMDATA,"^",7),PRCPLEFT,PRCPHL7)
;
;
Q S PRCPDONE=1
Q
;
ERR ;
N NUMBER
S NUMBER=ERR
S PRCPHLUT("SIPNAME")="" I $D(PRCPSEC) S PRCPHLUT("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSEC)
S PRCPHLUT("ITEM")="" I $D(PRCPITEM) S PRCPHLUT("ITEM")=PRCPITEM
S PRCPHLUT("NAME")="" I $D(PRCPITNM) S PRCPHLUT("NAME")=PRCPITNM
S PRCPHLUT("QTY")="" I $D(PRCPAMT) S PRCPHLUT("QTY")=PRCPAMT
S PRCPHLUT("LEFT")="" I $D(PRCPLEFT) S PRCPHLUT("LEFT")=PRCPLEFT
S PRCPHLUT("ACTIVITY")=""
I $D(PRCPREAS) S PRCPHLUT("ACTIVITY")=$E(PRCPREAS,1,4)
; . I $E(PRCPREAS,1,4)="USGE" S PRCPHLUT("ACTIVITY")="USAGE"
; . I $E(PRCPREAS,1,4)="RTRN" S PRCPHLUT("ACTIVITY")="RETURNED ITEM"
; . I $E(PRCPREAS,1,4)="DISP" S PRCPHLUT("ACTIVITY")="DISPOSED ITEM"
; . I $E(PRCPREAS,1,4)="ADJI" S PRCPHLUT("ACTIVITY")="ADJUSTED INVENTORY UP"
; . I $E(PRCPREAS,1,4)="ADJD" S PRCPHLUT("ACTIVITY")="ADJUSTED INVENTORY DOWN"
S PRCPHLUT("RECIPIENT")="an unspecified patient" I $D(PRCPREC) S PRCPHLUT("RECIPIENT")=PRCPREC
S PRCPHLUT("USER")="" I $D(PRCPUSER) S PRCPHLUT("USER")=PRCPUSER
D ERR^PRCPHLM0(ERR,"PRCP_BAD_ACTIVITY",PRCPSEC,.PRCPHLUT,PRCPHL7)
G Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPHLUT 3809 printed Apr 09, 2024@21:10:47 Page 2
PRCPHLUT ;WISC/CC-Process activity information from file 447.1 ;4/00
V ;;5.1;IFCAP;**1,24**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
PROCESS(PRCPDA,PRCPDONE) ;
+1 NEW %,ERR,ITEM,ITEMDATA,PRCPAMT,PRCPDATA,PRCPHLUT,PRCPITDA
+2 NEW PRCPITEM,PRCPITNM,PRCPLEFT,PRCPREAS,PRCPREC,PRCPSEC,PRCPSSFL,PRCPTIME
+3 NEW PRCPUSER,TRANORDR,TYPE
+4 ;
+5 SET PRCPDONE=0
+6 SET PRCPDATA=^PRCP(447.1,PRCPDA,0)
+7 SET PRCPHL7=$PIECE(PRCPDATA,"^",6)_".447.1"
+8 SET PRCPSEC=$PIECE(PRCPDATA,"^",3)
+9 SET PRCPTIME=$PIECE(PRCPDATA,"^",8)
+10 SET PRCPREC=$PIECE(PRCPDATA,"^",9)
+11 SET PRCPUSER=$PIECE(PRCPDATA,"^",10)
+12 SET PRCPREAS=$PIECE(PRCPDATA,"^",11)
+13 SET PRCPACTV=$PIECE(PRCPREAS,"~",1)
+14 ;
+15 SET PRCPITDA=0
+16 ; no item info
SET PRCPITDA=$ORDER(^PRCP(447.1,PRCPDA,1,PRCPITDA))
IF '+PRCPITDA
SET ERR="6F"
GOTO ERR
+17 SET PRCPDATA=^PRCP(447.1,PRCPDA,1,PRCPITDA,0)
+18 ; REFILL QTY - patient issue units
SET PRCPAMT=$PIECE(PRCPDATA,"^",3)
+19 IF PRCPACTV="USGE"!(PRCPACTV="DISP")!(PRCPACTV="ADJD")
SET PRCPAMT=-PRCPAMT
+20 SET PRCPITEM=$PIECE(PRCPDATA,"^",1)
+21 SET PRCPITNM=$PIECE(PRCPDATA,"^",4)
+22 ; patient issue units
SET PRCPLEFT=$PIECE(PRCPDATA,"^",2)
+23 ;
+24 ; secondary not in GIP
IF '$DATA(^PRCP(445,PRCPSEC))
SET ERR="3A"
GOTO ERR
+25 ; not a secondary
IF $PIECE(^PRCP(445,PRCPSEC,0),"^",3)'="S"
SET ERR="3B"
GOTO ERR
+26 IF '$DATA(^PRCP(445,PRCPSEC,1,PRCPITEM))
SET ERR="6C"
GOTO ERR
+27 ; is item a supply station item?
IF $PIECE(^PRCP(445,PRCPSEC,1,PRCPITEM,0),"^",9)'>0
SET ERR="6D"
GOTO ERR
+28 ; not a supply station secondary
IF $PIECE($GET(^PRCP(445,PRCPSEC,5)),"^",1)']""
SET ERR="3F"
GOTO ERR
+29 ; compare name in 445 to name sent, CONTINUE
+30 SET PRCPSSFL=$PIECE(^PRCP(445.5,$PIECE(^PRCP(445,PRCPSEC,5),"^",1),0),"^",2)
+31 IF PRCPSSFL="O"
IF $PIECE(^PRC(441,PRCPITEM,0),"^",2)'=PRCPITNM
DO NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
+32 IF PRCPSSFL="S"
IF $GET(^PRCP(445,PRCPSEC,1,PRCPITEM,6))'=PRCPITNM
DO NAME^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,PRCPSSFL,PRCPHL7)
+33 ;
UPDATE SET ITEMDATA=$GET(^PRCP(445,PRCPSEC,1,PRCPITEM,0))
+1 ; send message
IF ITEMDATA=""
SET ERR="6C"
GOTO ERR
+2 SET TYPE="U"
+3 IF $EXTRACT($PIECE(PRCPREAS,"~",1),1,3)="ADJ"!($PIECE(PRCPREAS,"~")="DISP")
SET TYPE="A"
+4 SET PRCPHLUT("INVVAL")=$JUSTIFY(PRCPAMT*$PIECE(ITEMDATA,"^",22),0,2)
+5 SET PRCPHLUT("DATE")=PRCPTIME
+6 SET PRCPHLUT("ITEM")=ITEMDATA
+7 SET PRCPHLUT("REASON")=$PIECE(PRCPREAS,"~",1)_":"_$PIECE(PRCPREAS,"~",2)
+8 SET PRCPHLUT("RECIPIENT")=$TRANSLATE(PRCPREC,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+9 SET PRCPHLUT("USER")=PRCPUSER
+10 SET PRCPHLUT("SELVAL")=PRCPHLUT("INVVAL")
+11 SET PRCPHLUT("QTY")=PRCPAMT
+12 ;
+13 ; save values into GIP files
+14 DO UPDATE^PRCPHL1(PRCPSEC,PRCPITEM,PRCPLEFT,.PRCPHLUT,TYPE)
+15 ;
+16 ; check expected qty remaining
+17 SET ITEMDATA=$GET(^PRCP(445,PRCPSEC,1,PRCPITEM,0))
+18 IF $PIECE(ITEMDATA,"^",7)'=PRCPLEFT
Begin DoDot:1
+19 DO QTYDISC^PRCPHL70(PRCPSEC,PRCPITEM,PRCPITNM,$PIECE(ITEMDATA,"^",7),PRCPLEFT,PRCPHL7)
End DoDot:1
+20 ;
+21 ;
Q SET PRCPDONE=1
+1 QUIT
+2 ;
ERR ;
+1 NEW NUMBER
+2 SET NUMBER=ERR
+3 SET PRCPHLUT("SIPNAME")=""
IF $DATA(PRCPSEC)
SET PRCPHLUT("SIPNAME")=$$INVNAME^PRCPUX1(PRCPSEC)
+4 SET PRCPHLUT("ITEM")=""
IF $DATA(PRCPITEM)
SET PRCPHLUT("ITEM")=PRCPITEM
+5 SET PRCPHLUT("NAME")=""
IF $DATA(PRCPITNM)
SET PRCPHLUT("NAME")=PRCPITNM
+6 SET PRCPHLUT("QTY")=""
IF $DATA(PRCPAMT)
SET PRCPHLUT("QTY")=PRCPAMT
+7 SET PRCPHLUT("LEFT")=""
IF $DATA(PRCPLEFT)
SET PRCPHLUT("LEFT")=PRCPLEFT
+8 SET PRCPHLUT("ACTIVITY")=""
+9 IF $DATA(PRCPREAS)
SET PRCPHLUT("ACTIVITY")=$EXTRACT(PRCPREAS,1,4)
+10 ; . I $E(PRCPREAS,1,4)="USGE" S PRCPHLUT("ACTIVITY")="USAGE"
+11 ; . I $E(PRCPREAS,1,4)="RTRN" S PRCPHLUT("ACTIVITY")="RETURNED ITEM"
+12 ; . I $E(PRCPREAS,1,4)="DISP" S PRCPHLUT("ACTIVITY")="DISPOSED ITEM"
+13 ; . I $E(PRCPREAS,1,4)="ADJI" S PRCPHLUT("ACTIVITY")="ADJUSTED INVENTORY UP"
+14 ; . I $E(PRCPREAS,1,4)="ADJD" S PRCPHLUT("ACTIVITY")="ADJUSTED INVENTORY DOWN"
+15 SET PRCPHLUT("RECIPIENT")="an unspecified patient"
IF $DATA(PRCPREC)
SET PRCPHLUT("RECIPIENT")=PRCPREC
+16 SET PRCPHLUT("USER")=""
IF $DATA(PRCPUSER)
SET PRCPHLUT("USER")=PRCPUSER
+17 DO ERR^PRCPHLM0(ERR,"PRCP_BAD_ACTIVITY",PRCPSEC,.PRCPHLUT,PRCPHL7)
+18 GOTO Q
