PRCPSLOI ;WISC/RFJ-create and transmit 663,669 code sheets ;19 Feb 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DQ(TRANNO,TRANID) ; create/trans receiving code sheets to log
; tranno=transaction number
; tranid=tran register id number
N %,%H,%I,COSTCNTR,COUNT,CP,DATA,DATE,DATEREC,DEPT,DESC,DIETPER,DISYS,INVPT,ITEMDATA,NSN,QTY,PRCPXMZ,TRANDA,TRANREG,TRANTYPE,UI,V,X
S CP=$P(TRANNO,"-",4),TRANTYPE=663 I $P($G(^PRC(420,+TRANNO,1,+CP,0)),"^",12)=3 S TRANTYPE=669,CP="CTN"
I $P($G(^PRC(420,+TRANNO,1,+CP,0)),"^",12)=1 S TRANTYPE=669,CP="GPF"
S TRANDA=+$O(^PRCS(410,"B",TRANNO,0)),INVPT=+$P($G(^PRCS(410,TRANDA,0)),"^",6),DEPT=$P($G(^PRCP(445,INVPT,0)),"^",8) I DEPT="",'$G(PRCPFLAG) D ASKDEPT I $G(PRCPFLAG) W !,$$ERROR^PRCPSLOR
S DEPT=$E(" ",$L(DEPT)+1,3)_DEPT,COSTCNTR=+$P($G(^PRCS(410,TRANDA,3)),"^",3) S:COSTCNTR=0 COSTCNTR="" S COSTCNTR=$E(" ",$L(COSTCNTR)+1,6)_COSTCNTR S:TRANTYPE=669!(CP="GPF") COSTCNTR="000000"
S DIETPER=" " I $E(DEPT,1,2)=11 S DIETPER=$P($G(^PRCS(410,TRANDA,100)),"^",2) I DIETPER="",'$G(PRCPFLAG) D ASKPER I $G(PRCPFLAG) W !,$$ERROR^PRCPSLOR
S:DIETPER="" DIETPER=" "
K ^TMP($J,"STRING") S TRANREG=0,COUNT=1 F S TRANREG=$O(^PRCP(445.2,"C",TRANNO,TRANREG)) Q:'TRANREG S DATA=$G(^PRCP(445.2,TRANREG,0)) I DATA'="",$P(DATA,"^",2)=TRANID D
. I '$G(DATE) S DATE=$P(DATA,"^",3),DATEREC=+$E(DATE,4,5),DATEREC=$S(DATEREC=10:0,DATEREC=11:"J",DATEREC=12:"K",1:DATEREC)
. S ITEMDATA=$G(^PRC(441,+$P(DATA,"^",5),0)),NSN=" "_$E($TR($P($P(ITEMDATA,"^",5),"-",2,4),"-")_" ",1,10),UI=$E($P($P(DATA,"^",6),"/",2)_" ",1,2)
. S DESC=$E($P(ITEMDATA,"^",2)_" ",1,21),V=$E($P(DATA,"^",15),2,6),V=$E(" ",$L(V)+1,5)_V,QTY=-$P(DATA,"^",7) S:QTY<0 QTY=-QTY S QTY=$E("00000",$L(QTY)+1,5)_QTY
. S ^TMP($J,"STRING",COUNT)=NSN_$P(TRANNO,"-")_TRANTYPE_" "_DESC_UI_DEPT_V_" "_QTY_" "_DIETPER_CP_DATEREC_COSTCNTR_" ",COUNT=COUNT+1
I COUNT=1 Q
D TRANSMIT^PRCPSMCL($P(TRANNO,"-"),TRANTYPE,"LOG")
W !!?4,"LOG ",TRANTYPE," Transmitted in MailMan Messages:" I $D(PRCPXMZ) S %=0 F S %=$O(PRCPXMZ(%)) Q:'% W " ",PRCPXMZ(%)," "
Q
;
;
ASKDEPT ; ask department number
; prcpflag is returned if incorrect response
N DTOUT,DUOUT,DIRUT S DIR(0)="F^3:3",DIR("A")="Enter DEPARTMENT NUMBER" W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S PRCPFLAG=1 Q
I Y["^" S PRCPFLAG=1 Q
S DEPT=X S:$D(^PRCP(445,INVPT,0)) $P(^(0),"^",8)=DEPT Q
;
;
ASKPER ; ask dietetic period
; prcpflag is returned if incorrect response
N DTOUT,DUOUT,DIRUT S DIR(0)="S^1:FIRST REPORT;2:SECOND REPORT;N:NO REPORT;",DIR("A")="Enter DIETETIC COST REPORT" W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S PRCPFLAG=1 Q
I Y["^" S PRCPFLAG=1 Q
S DIETPER=Y,$P(^PRCS(410,TRANDA,100),"^",2)=Y Q
;
;
ASKDEPOT ; ask depot number (field 107 in 442)
; prcpflag is returned if incorrect response
N DTOUT,DUOUT,DIRUT S DIR(0)="F^3:3",DIR("A")="Enter DEPOT Number from shipping document" W ! S:$G(DEPOT)'="" DIR("B")=DEPOT D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S PRCPFLAG=1 Q
I Y["^" S PRCPFLAG=1 Q
S DEPOT=X,$P(^PRC(442,PODA,18),"^")=X Q
;
;
ASKVOUCH ; ask depot voucher number (field .09 in 442)
; prcpflag is returned if incorrect response
N DTOUT,DUOUT,DIRUT S DIR(0)="F^5:5",DIR("A")="Enter DEPOT VOUCHER Number from shipping document" W ! S:$G(VOUCHER)'="" DIR("B")=VOUCHER D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S PRCPFLAG=1 Q
I Y["^" S PRCPFLAG=1 Q
S VOUCHER=X,$P(^PRC(442,PODA,1),"^",13)=X Q
;
;
ASKREQNO ; ask requisition number (supply) (field 102.4 in 442)
; prcpflag is returned if incorrect response
N DTOUT,DUOUT,DIRUT S DIR(0)="F^5:5",DIR("A")="Enter REQUISITION NO. (SUPPLY)" W ! D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S PRCPFLAG=1 Q
I Y["^" S PRCPFLAG=1 Q
S REQNO=X,$P(^PRC(442,PODA,18),"^",10)=STATION_"-"_$E(X,1,3)_"-"_$E(X,4,5) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSLOI 3984 printed Sep 23, 2025@19:51:53 Page 2
PRCPSLOI ;WISC/RFJ-create and transmit 663,669 code sheets ;19 Feb 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
DQ(TRANNO,TRANID) ; create/trans receiving code sheets to log
+1 ; tranno=transaction number
+2 ; tranid=tran register id number
+3 NEW %,%H,%I,COSTCNTR,COUNT,CP,DATA,DATE,DATEREC,DEPT,DESC,DIETPER,DISYS,INVPT,ITEMDATA,NSN,QTY,PRCPXMZ,TRANDA,TRANREG,TRANTYPE,UI,V,X
+4 SET CP=$PIECE(TRANNO,"-",4)
SET TRANTYPE=663
IF $PIECE($GET(^PRC(420,+TRANNO,1,+CP,0)),"^",12)=3
SET TRANTYPE=669
SET CP="CTN"
+5 IF $PIECE($GET(^PRC(420,+TRANNO,1,+CP,0)),"^",12)=1
SET TRANTYPE=669
SET CP="GPF"
+6 SET TRANDA=+$ORDER(^PRCS(410,"B",TRANNO,0))
SET INVPT=+$PIECE($GET(^PRCS(410,TRANDA,0)),"^",6)
SET DEPT=$PIECE($GET(^PRCP(445,INVPT,0)),"^",8)
IF DEPT=""
IF '$GET(PRCPFLAG)
DO ASKDEPT
IF $GET(PRCPFLAG)
WRITE !,$$ERROR^PRCPSLOR
+7 SET DEPT=$EXTRACT(" ",$LENGTH(DEPT)+1,3)_DEPT
SET COSTCNTR=+$PIECE($GET(^PRCS(410,TRANDA,3)),"^",3)
if COSTCNTR=0
SET COSTCNTR=""
SET COSTCNTR=$EXTRACT(" ",$LENGTH(COSTCNTR)+1,6)_COSTCNTR
if TRANTYPE=669!(CP="GPF")
SET COSTCNTR="000000"
+8 SET DIETPER=" "
IF $EXTRACT(DEPT,1,2)=11
SET DIETPER=$PIECE($GET(^PRCS(410,TRANDA,100)),"^",2)
IF DIETPER=""
IF '$GET(PRCPFLAG)
DO ASKPER
IF $GET(PRCPFLAG)
WRITE !,$$ERROR^PRCPSLOR
+9 if DIETPER=""
SET DIETPER=" "
+10 KILL ^TMP($JOB,"STRING")
SET TRANREG=0
SET COUNT=1
FOR
SET TRANREG=$ORDER(^PRCP(445.2,"C",TRANNO,TRANREG))
if 'TRANREG
QUIT
SET DATA=$GET(^PRCP(445.2,TRANREG,0))
IF DATA'=""
IF $PIECE(DATA,"^",2)=TRANID
Begin DoDot:1
+11 IF '$GET(DATE)
SET DATE=$PIECE(DATA,"^",3)
SET DATEREC=+$EXTRACT(DATE,4,5)
SET DATEREC=$SELECT(DATEREC=10:0,DATEREC=11:"J",DATEREC=12:"K",1:DATEREC)
+12 SET ITEMDATA=$GET(^PRC(441,+$PIECE(DATA,"^",5),0))
SET NSN=" "_$EXTRACT($TRANSLATE($PIECE($PIECE(ITEMDATA,"^",5),"-",2,4),"-")_" ",1,10)
SET UI=$EXTRACT($PIECE($PIECE(DATA,"^",6),"/",2)_" ",1,2)
+13 SET DESC=$EXTRACT($PIECE(ITEMDATA,"^",2)_" ",1,21)
SET V=$EXTRACT($PIECE(DATA,"^",15),2,6)
SET V=$EXTRACT(" ",$LENGTH(V)+1,5)_V
SET QTY=-$PIECE(DATA,"^",7)
if QTY<0
SET QTY=-QTY
SET QTY=$EXTRACT("00000",$LENGTH(QTY)+1,5)_QTY
+14 SET ^TMP($JOB,"STRING",COUNT)=NSN_$PIECE(TRANNO,"-")_TRANTYPE_" "_DESC_UI_DEPT_V_" "_QTY_" "_DIETPER_CP_DATEREC_COSTCNTR_" "
SET COUNT=COUNT+1
End DoDot:1
+15 IF COUNT=1
QUIT
+16 DO TRANSMIT^PRCPSMCL($PIECE(TRANNO,"-"),TRANTYPE,"LOG")
+17 WRITE !!?4,"LOG ",TRANTYPE," Transmitted in MailMan Messages:"
IF $DATA(PRCPXMZ)
SET %=0
FOR
SET %=$ORDER(PRCPXMZ(%))
if '%
QUIT
WRITE " ",PRCPXMZ(%)," "
+18 QUIT
+19 ;
+20 ;
ASKDEPT ; ask department number
+1 ; prcpflag is returned if incorrect response
+2 NEW DTOUT,DUOUT,DIRUT
SET DIR(0)="F^3:3"
SET DIR("A")="Enter DEPARTMENT NUMBER"
WRITE !
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET PRCPFLAG=1
QUIT
+3 IF Y["^"
SET PRCPFLAG=1
QUIT
+4 SET DEPT=X
if $DATA(^PRCP(445,INVPT,0))
SET $PIECE(^(0),"^",8)=DEPT
QUIT
+5 ;
+6 ;
ASKPER ; ask dietetic period
+1 ; prcpflag is returned if incorrect response
+2 NEW DTOUT,DUOUT,DIRUT
SET DIR(0)="S^1:FIRST REPORT;2:SECOND REPORT;N:NO REPORT;"
SET DIR("A")="Enter DIETETIC COST REPORT"
WRITE !
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET PRCPFLAG=1
QUIT
+3 IF Y["^"
SET PRCPFLAG=1
QUIT
+4 SET DIETPER=Y
SET $PIECE(^PRCS(410,TRANDA,100),"^",2)=Y
QUIT
+5 ;
+6 ;
ASKDEPOT ; ask depot number (field 107 in 442)
+1 ; prcpflag is returned if incorrect response
+2 NEW DTOUT,DUOUT,DIRUT
SET DIR(0)="F^3:3"
SET DIR("A")="Enter DEPOT Number from shipping document"
WRITE !
if $GET(DEPOT)'=""
SET DIR("B")=DEPOT
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET PRCPFLAG=1
QUIT
+3 IF Y["^"
SET PRCPFLAG=1
QUIT
+4 SET DEPOT=X
SET $PIECE(^PRC(442,PODA,18),"^")=X
QUIT
+5 ;
+6 ;
ASKVOUCH ; ask depot voucher number (field .09 in 442)
+1 ; prcpflag is returned if incorrect response
+2 NEW DTOUT,DUOUT,DIRUT
SET DIR(0)="F^5:5"
SET DIR("A")="Enter DEPOT VOUCHER Number from shipping document"
WRITE !
if $GET(VOUCHER)'=""
SET DIR("B")=VOUCHER
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET PRCPFLAG=1
QUIT
+3 IF Y["^"
SET PRCPFLAG=1
QUIT
+4 SET VOUCHER=X
SET $PIECE(^PRC(442,PODA,1),"^",13)=X
QUIT
+5 ;
+6 ;
ASKREQNO ; ask requisition number (supply) (field 102.4 in 442)
+1 ; prcpflag is returned if incorrect response
+2 NEW DTOUT,DUOUT,DIRUT
SET DIR(0)="F^5:5"
SET DIR("A")="Enter REQUISITION NO. (SUPPLY)"
WRITE !
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET PRCPFLAG=1
QUIT
+3 IF Y["^"
SET PRCPFLAG=1
QUIT
+4 SET REQNO=X
SET $PIECE(^PRC(442,PODA,18),"^",10)=STATION_"-"_$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)
QUIT
