- 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 Mar 13, 2025@21:20:35 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
