PRCPLO1 ;WOIFO/RLL/DAP-utilities: setup inventory variables ; 1/24/06 9:56am
V ;;5.1;IFCAP;**83**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
; Copied from routine PRCPUSEL
PRCPUSEL ; Old routine label (to resolve goto below for xindex)
Q
;
; enter distribution point--input variables:
; prcp("dptype")=distribution point type code [W,P,S]
;
; returns the following variables:
; prcp("in")=name of inv pt (no station #),
; prcp("inv")=keep perpetual inventory flag
; prcp("his")=keep detailed history flag,
; prcp("i")=da of inv pt
;
DOIT ; ADDED label here
N D,IORVOFF,IORVON,PRCHAUTH ; needed to New for xindex
D DOIT1
Q
GETIPT ; $O through PRCP(^445,"B", get Station ID, Inactive?, IPID#
;
N V1,V2,V3,V4,V5,DATA1,DATA2
S V1=0,V2=0
F S V1=$O(^PRCP(445,"B",V1)) Q:V1="" D
. F S V2=$O(^PRCP(445,"B",V1,V2)) Q:V2="" D
. . Q:V1["***INACTIVE"
. . ;S V1=$TR(V1,"*","&") ; needed due to using "*" as delimiter
. . S V3=$P(V1,"-",1)
. . S V4=$P(V1,"-",2,99)
. . ; W !," Station ID#=",V3
. . ; W !," Inventory Point =",V4
. . ; W !," Inventory Point ID# =",V2
. . S DATA1=$G(^PRCP(445,+(V2),0)) ; DATA for Inv Point
. . S PRCP("DPTYPE")=$P(DATA1,"^",3) ; Prim, Second, or warehouse
. . S PRCP("PAR")=DATA1 ; Data for Inv point set in array
. . S PRCP("HIS")=$P(DATA1,"^",6) ;
. . S PRCP("I")=V2 ; Inv Point ID#
. . S PRCP("INV")=$P(DATA1,"^",2) ; External Name, Inv Point
. . ; W !,"DATA 1 IS ",DATA1
. . ;
. . S DATA2=$G(^PRC(411,+(V3),0)) ; Data for Station ID#
. . S PRC("PARAM")=DATA2 ; parameters for Station ID
. . S PRC("SITE")=V3 ; station id#
. . S PRC("MDIV")="" ; multi division , add lookup/check here
. . S PRC("PER")="" ; normally DUZ, may not be needed
. . S PRC("FY")="06"
. . S PRC("QTR")="01" ; add lookup/check here
. . ; W !," PRC(PARAM) IS ",PRC("PARAM")
. . ; THE WRITE STATEMENTS ABOVE WILL BE REPLACED WITH
. . ; THE SETTING OF PRCP() AND PRC() VALUES
. . ; *83 add code here from Days of Stock on hand logic
. . ; if Item Inventory does not contain any items for
. . ; an inventory point, quit here. Get next Inv. point
. . ; N ITMDAK
. . ; S ITMDAK=$G(^PRCP(445,+PRCP("I"),1,0)) ;at least 1 item?
. . ; Q:'ITMDAK ; quit if no item exists, go to next Inv. Pt.
. . I CLRSFLAG="SS" D EN1^PRCPLO2 ; Do stock status report
. . I CLRSFLAG="SOH" D EN1^PRCPLO ; Do days of stock on hand rpt.
. . Q
. Q
Q
;
;
DOIT1 ; ADDED label here
N %,C,DISYS,I,J,PRCF,PRCPFLAG,X,Y
I +$G(DUZ)<1 W !,"YOU ARE NOT SETUP AS A USER!" K PRC,PRCP Q
;
S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q
; I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q
;
DOSITE ; Set up PRC array from PRCFSITE
S PRC("MDIV")="" ; multi division (need to check for this)
S PRC("FY")="06" ; NEED TO make this calculation
S PRC("PARAM")=$G(^PRC(411,V2,0)) ; get params for inv pt
S PRC("PER")=DUZ ; may not be needed
S PRC("QTR")="01" ; NEED TO make this calcuation
S PRC("SITE")=V2
Q
;
DOSITEP ; Set up PRCP array from DISPLAY^PRCPLO1
S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$D(PRCP(I)) S %=1 Q
; I '% D DISPLAY Q
;
D PARAM(+V2)
Q
; allow adding new whse if not one for station
I $G(PRCP("DPTYPE"))="W" D Q:$G(PRCPFLAG)
. K PRCPFLAG
. S %=0 F S %=$O(^PRCP(445,"AC","W",%)) Q:'% I $P($P($G(^PRCP(445,%,0)),"^"),"-")=PRC("SITE") S PRCPFLAG=1 Q
. I $G(PRCPFLAG) K PRCPFLAG Q
. S PRCP("I")=$$INVPT^PRCPUINV(PRC("SITE"),"W",1,1,"")
. I 'PRCP("I") S PRCPFLAG=1 K PRC,PRCP
;
S %=$S($D(PRCP("DPTYPE")):PRCP("DPTYPE"),1:"^")
S (I,J)=0
F S I=$O(^PRCP(445,"AD",DUZ,I)) Q:'I I $D(^PRCP(445,I,0)) D I J>1 Q
. S:%="^"!(%[$P(^PRCP(445,I,0),"^",3)) Y(0)=^(0),J=J+1,Y=I
I J=1 D Q:$G(PRCPFLAG) S PRC("SITE")=+Y(0) D V1 Q
. I '$D(^PRC(411,+Y(0),0)) D K PRC,PRCP S PRCPFLAG=1
. . W !,"ERROR - SITE PARAMETERS IN FILE 411 FOR SITE "
. . W +Y(0)," ARE MISSING."
I $G(PRCHAUTH) Q:'$G(PRCP("I")) D G V1
. S Y=PRCP("I")_"^"_$P($G(^PRCP(445,PRCP("I"),0)),U)
;
S DIC="^PRCP(445,",DIC(0)="AEQMOZ"
S DIC("S")="I +^(0)=PRC(""SITE""),$P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))"
I $D(PRCP("DPTYPE")) S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)"
S DIC("A")="Select "_$S('$D(PRCP("DPTYPE")):"",PRCP("DPTYPE")="W":"Supply Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")_"Inventory Point: "
S D="C",PRCPPRIV=1
D IX^DIC
K PRCPPRIV,DIC
I Y<0 K PRC,PRCP Q
;
V1 ; internal program jump
D PARAM(+Y)
;
DISPLAY ; display top of page header
I '$G(PRCP("I")) G PRCPUSEL
S %=0 F I="RV1","RV0","XY" I '$D(PRCP(I)) S %=1 Q
I % D TERM
;
S %="",$P(%," ",81)=""
S X="I N V E N T O R Y version "_$P($T(PRCPUSEL+1),";",3)
S Y=80-$L(X)\2
S X=$E(%,1,Y)_X_%
W @IOF,PRCP("RV1"),$E(X,1,40)
X PRCP("XY")
W $E(X,41,80),PRCP("RV0")
S PRCP("PAR")=^PRCP(445,PRCP("I"),0)
S X=$S(+$G(PRC("SITE")):"("_PRC("SITE")_") ",1:"")
S X=X_$S(PRCP("DPTYPE")="W":"Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")
S X=X_"Inventory Point: "_PRCP("IN")
W !,X,?(80-$L($P($G(PRC("PER")),"^",2))),$P($G(PRC("PER")),"^",2)
I PRCP("DPTYPE")="P" S Y=$P(PRCP("PAR"),"^",12) I Y,Y'>DT D
. D DD^%DT
. W !,?6,"--> NEXT REQUEST FOR WAREHOUSE ISSUES IS DUE IN SUPPLY ON ",Y,"."
I $P(PRCP("PAR"),"^",9)="Y" D
. W !?6,"--> THERE ARE ITEMS AT OR BELOW THE EMERGENCY STOCK LEVEL."
I $E($P(PRCP("PAR"),"^",14),1,5)'=$E(DT,1,5) D
. W !?6,"--> USAGE/DISTRIBUTION TOTALS NEEDS TO BE PURGED."
I $E($P(PRCP("PAR"),"^",17),1,5)'=$E(DT,1,5) D
. W !?6,"--> RECEIPTS HISTORY BY ITEM NEEDS TO BE PURGED."
I PRCP("DPTYPE")'="S",$E($P(PRCP("PAR"),"^",19),1,5)'=$E(DT,1,5) D
. W !?6,"--> DISTRIBUTION HISTORY NEEDS TO BE PURGED."
I $E($P(PRCP("PAR"),"^",18),1,5)'=$E(DT,1,5) D
. W !?6,"--> TRANSACTION REGISTER NEEDS TO BE PURGED."
I $P(PRCP("PAR"),"^",6)="Y",$E($P(PRCP("PAR"),"^",22),1,5)'=$E(DT,1,5) D
. W !?6,"--> OPENING MONTHLY INVENTORY BALANCES NEED TO BE SET."
I PRCP("DPTYPE")="S",$P($G(^PRCP(445,PRCP("I"),5)),"^",1)]"" D SSMSG
I $O(^PRCP(447.1,"C",+PRCP("PAR"),PRCP("I"),"")) D
. W !?6,"--> THERE ARE UNPROCESSED SUPPLY STATION TRANSACTIONS."
;
W !,PRCP("RV1"),$E(%,1,40) X PRCP("XY") W $E(%,41,80),PRCP("RV0")
Q
;
;
; to the menu (called from option file)
N X
S X(1)="YOU MUST SELECT A VALID INVENTORY POINT BEFORE ACCESSING THIS MENU" D DISPLAY^PRCPUX2(1,79,.X)
Q
;
;
PARAM(INVPT) ; set up parameters for inventory point
K PRCP
N DATA,PRCPEX
S DATA=$G(^PRCP(445,INVPT,0)) I DATA="" Q
; *83 new code, need to $TR PRCP("IN", convert "*" to "|"
;S PRCP("I")=INVPT,PRCP("INV")=(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3)
;S PRCPEX=$P($P(DATA,"^"),"-",2,99)
;S PRCPEX=$TR(PRCPEX,"*","&") ; Change "*" to "|"
;S PRCP("IN")=PRCPEX
; *83 (old code below)
S PRCP("I")=INVPT,PRCP("IN")=$P($P(DATA,"^"),"-",2,99),PRCP("INV")=$P(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3)
; D TERM ;commented out for CLRS
Q
;
;
TERM ; get terminal attributes
N X
I '$D(IOF)!('$G(IOST(0))) S IOP="HOME" D ^%ZIS K IOP
S X="IORVON;IORVOFF" D ENDR^%ZISS
S PRCP("RV1")=$G(IORVON),PRCP("RV0")=$G(IORVOFF)
S PRCP("XY")="N DX,DY S (DX,DY)=0 "_$G(^%ZOSF("XY"))
Q
;
SSMSG ; check supply station secondaries, give message of qty mismatch
N GIPCNT,INVPT,ITEM,PRCPFLAG,SSCNT
S INVPT=PRCP("I")
S ITEM=0
F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D I $D(PRCPFLAG) Q
. I $P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1 Q ; not a SS item
. S GIPCNT=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",7)
. S SSCNT=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",1)
. I 'GIPCNT,'SSCNT Q
. I GIPCNT=SSCNT Q
. W !,?6,"--> QUANTITY DISCREPANCIES EXIST WITH THE SUPPLY STATION."
. S PRCPFLAG=1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPLO1 8072 printed Sep 23, 2025@19:50:09 Page 2
PRCPLO1 ;WOIFO/RLL/DAP-utilities: setup inventory variables ; 1/24/06 9:56am
V ;;5.1;IFCAP;**83**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ; Copied from routine PRCPUSEL
PRCPUSEL ; Old routine label (to resolve goto below for xindex)
+1 QUIT
+2 ;
+3 ; enter distribution point--input variables:
+4 ; prcp("dptype")=distribution point type code [W,P,S]
+5 ;
+6 ; returns the following variables:
+7 ; prcp("in")=name of inv pt (no station #),
+8 ; prcp("inv")=keep perpetual inventory flag
+9 ; prcp("his")=keep detailed history flag,
+10 ; prcp("i")=da of inv pt
+11 ;
DOIT ; ADDED label here
+1 ; needed to New for xindex
NEW D,IORVOFF,IORVON,PRCHAUTH
+2 DO DOIT1
+3 QUIT
GETIPT ; $O through PRCP(^445,"B", get Station ID, Inactive?, IPID#
+1 ;
+2 NEW V1,V2,V3,V4,V5,DATA1,DATA2
+3 SET V1=0
SET V2=0
+4 FOR
SET V1=$ORDER(^PRCP(445,"B",V1))
if V1=""
QUIT
Begin DoDot:1
+5 FOR
SET V2=$ORDER(^PRCP(445,"B",V1,V2))
if V2=""
QUIT
Begin DoDot:2
+6 if V1["***INACTIVE"
QUIT
+7 ;S V1=$TR(V1,"*","&") ; needed due to using "*" as delimiter
+8 SET V3=$PIECE(V1,"-",1)
+9 SET V4=$PIECE(V1,"-",2,99)
+10 ; W !," Station ID#=",V3
+11 ; W !," Inventory Point =",V4
+12 ; W !," Inventory Point ID# =",V2
+13 ; DATA for Inv Point
SET DATA1=$GET(^PRCP(445,+(V2),0))
+14 ; Prim, Second, or warehouse
SET PRCP("DPTYPE")=$PIECE(DATA1,"^",3)
+15 ; Data for Inv point set in array
SET PRCP("PAR")=DATA1
+16 ;
SET PRCP("HIS")=$PIECE(DATA1,"^",6)
+17 ; Inv Point ID#
SET PRCP("I")=V2
+18 ; External Name, Inv Point
SET PRCP("INV")=$PIECE(DATA1,"^",2)
+19 ; W !,"DATA 1 IS ",DATA1
+20 ;
+21 ; Data for Station ID#
SET DATA2=$GET(^PRC(411,+(V3),0))
+22 ; parameters for Station ID
SET PRC("PARAM")=DATA2
+23 ; station id#
SET PRC("SITE")=V3
+24 ; multi division , add lookup/check here
SET PRC("MDIV")=""
+25 ; normally DUZ, may not be needed
SET PRC("PER")=""
+26 SET PRC("FY")="06"
+27 ; add lookup/check here
SET PRC("QTR")="01"
+28 ; W !," PRC(PARAM) IS ",PRC("PARAM")
+29 ; THE WRITE STATEMENTS ABOVE WILL BE REPLACED WITH
+30 ; THE SETTING OF PRCP() AND PRC() VALUES
+31 ; *83 add code here from Days of Stock on hand logic
+32 ; if Item Inventory does not contain any items for
+33 ; an inventory point, quit here. Get next Inv. point
+34 ; N ITMDAK
+35 ; S ITMDAK=$G(^PRCP(445,+PRCP("I"),1,0)) ;at least 1 item?
+36 ; Q:'ITMDAK ; quit if no item exists, go to next Inv. Pt.
+37 ; Do stock status report
IF CLRSFLAG="SS"
DO EN1^PRCPLO2
+38 ; Do days of stock on hand rpt.
IF CLRSFLAG="SOH"
DO EN1^PRCPLO
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 QUIT
+42 ;
+43 ;
DOIT1 ; ADDED label here
+1 NEW %,C,DISYS,I,J,PRCF,PRCPFLAG,X,Y
+2 IF +$GET(DUZ)<1
WRITE !,"YOU ARE NOT SETUP AS A USER!"
KILL PRC,PRCP
QUIT
+3 ;
+4 SET %=0
FOR I="FY","PARAM","PER","QTR","SITE"
IF '+$GET(PRC(I))
SET %=1
QUIT
+5 ; I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q
+6 ;
DOSITE ; Set up PRC array from PRCFSITE
+1 ; multi division (need to check for this)
SET PRC("MDIV")=""
+2 ; NEED TO make this calculation
SET PRC("FY")="06"
+3 ; get params for inv pt
SET PRC("PARAM")=$GET(^PRC(411,V2,0))
+4 ; may not be needed
SET PRC("PER")=DUZ
+5 ; NEED TO make this calcuation
SET PRC("QTR")="01"
+6 SET PRC("SITE")=V2
+7 QUIT
+8 ;
DOSITEP ; Set up PRCP array from DISPLAY^PRCPLO1
+1 SET %=0
FOR I="DPTYPE","HIS","I","IN","INV"
IF '$DATA(PRCP(I))
SET %=1
QUIT
+2 ; I '% D DISPLAY Q
+3 ;
+4 DO PARAM(+V2)
+5 QUIT
+6 ; allow adding new whse if not one for station
+7 IF $GET(PRCP("DPTYPE"))="W"
Begin DoDot:1
+8 KILL PRCPFLAG
+9 SET %=0
FOR
SET %=$ORDER(^PRCP(445,"AC","W",%))
if '%
QUIT
IF $PIECE($PIECE($GET(^PRCP(445,%,0)),"^"),"-")=PRC("SITE")
SET PRCPFLAG=1
QUIT
+10 IF $GET(PRCPFLAG)
KILL PRCPFLAG
QUIT
+11 SET PRCP("I")=$$INVPT^PRCPUINV(PRC("SITE"),"W",1,1,"")
+12 IF 'PRCP("I")
SET PRCPFLAG=1
KILL PRC,PRCP
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+13 ;
+14 SET %=$SELECT($DATA(PRCP("DPTYPE")):PRCP("DPTYPE"),1:"^")
+15 SET (I,J)=0
+16 FOR
SET I=$ORDER(^PRCP(445,"AD",DUZ,I))
if 'I
QUIT
IF $DATA(^PRCP(445,I,0))
Begin DoDot:1
+17 if %="^"!(%[$PIECE(^PRCP(445,I,0),"^",3))
SET Y(0)=^(0)
SET J=J+1
SET Y=I
End DoDot:1
IF J>1
QUIT
+18 IF J=1
Begin DoDot:1
+19 IF '$DATA(^PRC(411,+Y(0),0))
Begin DoDot:2
+20 WRITE !,"ERROR - SITE PARAMETERS IN FILE 411 FOR SITE "
+21 WRITE +Y(0)," ARE MISSING."
End DoDot:2
KILL PRC,PRCP
SET PRCPFLAG=1
End DoDot:1
if $GET(PRCPFLAG)
QUIT
SET PRC("SITE")=+Y(0)
DO V1
QUIT
+22 IF $GET(PRCHAUTH)
if '$GET(PRCP("I"))
QUIT
Begin DoDot:1
+23 SET Y=PRCP("I")_"^"_$PIECE($GET(^PRCP(445,PRCP("I"),0)),U)
End DoDot:1
GOTO V1
+24 ;
+25 SET DIC="^PRCP(445,"
SET DIC(0)="AEQMOZ"
+26 SET DIC("S")="I +^(0)=PRC(""SITE""),$P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))"
+27 IF $DATA(PRCP("DPTYPE"))
SET DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)"
+28 SET DIC("A")="Select "_$SELECT('$DATA(PRCP("DPTYPE")):"",PRCP("DPTYPE")="W":"Supply Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")_"Inventory Point: "
+29 SET D="C"
SET PRCPPRIV=1
+30 DO IX^DIC
+31 KILL PRCPPRIV,DIC
+32 IF Y<0
KILL PRC,PRCP
QUIT
+33 ;
V1 ; internal program jump
+1 DO PARAM(+Y)
+2 ;
DISPLAY ; display top of page header
+1 IF '$GET(PRCP("I"))
GOTO PRCPUSEL
+2 SET %=0
FOR I="RV1","RV0","XY"
IF '$DATA(PRCP(I))
SET %=1
QUIT
+3 IF %
DO TERM
+4 ;
+5 SET %=""
SET $PIECE(%," ",81)=""
+6 SET X="I N V E N T O R Y version "_$PIECE($TEXT(PRCPUSEL+1),";",3)
+7 SET Y=80-$LENGTH(X)\2
+8 SET X=$EXTRACT(%,1,Y)_X_%
+9 WRITE @IOF,PRCP("RV1"),$EXTRACT(X,1,40)
+10 XECUTE PRCP("XY")
+11 WRITE $EXTRACT(X,41,80),PRCP("RV0")
+12 SET PRCP("PAR")=^PRCP(445,PRCP("I"),0)
+13 SET X=$SELECT(+$GET(PRC("SITE")):"("_PRC("SITE")_") ",1:"")
+14 SET X=X_$SELECT(PRCP("DPTYPE")="W":"Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")
+15 SET X=X_"Inventory Point: "_PRCP("IN")
+16 WRITE !,X,?(80-$LENGTH($PIECE($GET(PRC("PER")),"^",2))),$PIECE($GET(PRC("PER")),"^",2)
+17 IF PRCP("DPTYPE")="P"
SET Y=$PIECE(PRCP("PAR"),"^",12)
IF Y
IF Y'>DT
Begin DoDot:1
+18 DO DD^%DT
+19 WRITE !,?6,"--> NEXT REQUEST FOR WAREHOUSE ISSUES IS DUE IN SUPPLY ON ",Y,"."
End DoDot:1
+20 IF $PIECE(PRCP("PAR"),"^",9)="Y"
Begin DoDot:1
+21 WRITE !?6,"--> THERE ARE ITEMS AT OR BELOW THE EMERGENCY STOCK LEVEL."
End DoDot:1
+22 IF $EXTRACT($PIECE(PRCP("PAR"),"^",14),1,5)'=$EXTRACT(DT,1,5)
Begin DoDot:1
+23 WRITE !?6,"--> USAGE/DISTRIBUTION TOTALS NEEDS TO BE PURGED."
End DoDot:1
+24 IF $EXTRACT($PIECE(PRCP("PAR"),"^",17),1,5)'=$EXTRACT(DT,1,5)
Begin DoDot:1
+25 WRITE !?6,"--> RECEIPTS HISTORY BY ITEM NEEDS TO BE PURGED."
End DoDot:1
+26 IF PRCP("DPTYPE")'="S"
IF $EXTRACT($PIECE(PRCP("PAR"),"^",19),1,5)'=$EXTRACT(DT,1,5)
Begin DoDot:1
+27 WRITE !?6,"--> DISTRIBUTION HISTORY NEEDS TO BE PURGED."
End DoDot:1
+28 IF $EXTRACT($PIECE(PRCP("PAR"),"^",18),1,5)'=$EXTRACT(DT,1,5)
Begin DoDot:1
+29 WRITE !?6,"--> TRANSACTION REGISTER NEEDS TO BE PURGED."
End DoDot:1
+30 IF $PIECE(PRCP("PAR"),"^",6)="Y"
IF $EXTRACT($PIECE(PRCP("PAR"),"^",22),1,5)'=$EXTRACT(DT,1,5)
Begin DoDot:1
+31 WRITE !?6,"--> OPENING MONTHLY INVENTORY BALANCES NEED TO BE SET."
End DoDot:1
+32 IF PRCP("DPTYPE")="S"
IF $PIECE($GET(^PRCP(445,PRCP("I"),5)),"^",1)]""
DO SSMSG
+33 IF $ORDER(^PRCP(447.1,"C",+PRCP("PAR"),PRCP("I"),""))
Begin DoDot:1
+34 WRITE !?6,"--> THERE ARE UNPROCESSED SUPPLY STATION TRANSACTIONS."
End DoDot:1
+35 ;
+36 WRITE !,PRCP("RV1"),$EXTRACT(%,1,40)
XECUTE PRCP("XY")
WRITE $EXTRACT(%,41,80),PRCP("RV0")
+37 QUIT
+38 ;
+39 ;
+1 ; to the menu (called from option file)
+2 NEW X
+3 SET X(1)="YOU MUST SELECT A VALID INVENTORY POINT BEFORE ACCESSING THIS MENU"
DO DISPLAY^PRCPUX2(1,79,.X)
+4 QUIT
+5 ;
+6 ;
PARAM(INVPT) ; set up parameters for inventory point
+1 KILL PRCP
+2 NEW DATA,PRCPEX
+3 SET DATA=$GET(^PRCP(445,INVPT,0))
IF DATA=""
QUIT
+4 ; *83 new code, need to $TR PRCP("IN", convert "*" to "|"
+5 ;S PRCP("I")=INVPT,PRCP("INV")=(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3)
+6 ;S PRCPEX=$P($P(DATA,"^"),"-",2,99)
+7 ;S PRCPEX=$TR(PRCPEX,"*","&") ; Change "*" to "|"
+8 ;S PRCP("IN")=PRCPEX
+9 ; *83 (old code below)
+10 SET PRCP("I")=INVPT
SET PRCP("IN")=$PIECE($PIECE(DATA,"^"),"-",2,99)
SET PRCP("INV")=$PIECE(DATA,"^",2)
SET PRCP("HIS")=$PIECE(DATA,"^",6)
SET PRCP("DPTYPE")=$PIECE(DATA,"^",3)
+11 ; D TERM ;commented out for CLRS
+12 QUIT
+13 ;
+14 ;
TERM ; get terminal attributes
+1 NEW X
+2 IF '$DATA(IOF)!('$GET(IOST(0)))
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+3 SET X="IORVON;IORVOFF"
DO ENDR^%ZISS
+4 SET PRCP("RV1")=$GET(IORVON)
SET PRCP("RV0")=$GET(IORVOFF)
+5 SET PRCP("XY")="N DX,DY S (DX,DY)=0 "_$GET(^%ZOSF("XY"))
+6 QUIT
+7 ;
SSMSG ; check supply station secondaries, give message of qty mismatch
+1 NEW GIPCNT,INVPT,ITEM,PRCPFLAG,SSCNT
+2 SET INVPT=PRCP("I")
+3 SET ITEM=0
+4 FOR
SET ITEM=$ORDER(^PRCP(445,INVPT,1,ITEM))
if '+ITEM
QUIT
Begin DoDot:1
+5 ; not a SS item
IF $PIECE($GET(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1
QUIT
+6 SET GIPCNT=$PIECE($GET(^PRCP(445,INVPT,1,ITEM,0)),"^",7)
+7 SET SSCNT=$PIECE($GET(^PRCP(445,INVPT,1,ITEM,9)),"^",1)
+8 IF 'GIPCNT
IF 'SSCNT
QUIT
+9 IF GIPCNT=SSCNT
QUIT
+10 WRITE !,?6,"--> QUANTITY DISCREPANCIES EXIST WITH THE SUPPLY STATION."
+11 SET PRCPFLAG=1
End DoDot:1
IF $DATA(PRCPFLAG)
QUIT
