- PRCPSLOR ;WISC/RFJ-receiving code sheets to log ;22 Feb 92
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- DQ ; create/trans receiving code sheets to isms (log)
- ; pono=purchase order number
- ; tranid=transaction register id number
- ; partlda=partial number (optional) - if set, can determine
- ; if this receipt is a partial or final.
- ; prc=standard variables defined (for creating code sheets)
- N %,COST,COUNT,DATA,DATE,DATEREC,DESC,DISYS,DOCID,FY,ITEMDATA,NDC,NSN,PARTIAL,PAYABLE,PRCPXMZ,PODA,QTY,RELESFAC,SFCP,SOURCE,SRCEDEV,TRANREG,UI,X,X1,X2,X3
- S PODA=+$O(^PRC(442,"B",PONO,0)),SOURCE=+$P($G(^PRCD(420.8,+$P($G(^PRC(442,PODA,1)),"^",7),0)),"^") S:SOURCE="" SOURCE=" " S SRCEDEV=$P($G(^PRC(442,PODA,17)),"^",13) S:SRCEDEV="" SRCEDEV=" " I SOURCE="B" S SOURCE=6
- ; get document identifier
- S DOCID=$E($P(PONO,"-",2))_$E($P(PONO,"-",2),3,6),DOCID=$E(" ",$L(DOCID)+1,5)_DOCID
- ; get fiscal year of funding and date
- S %=+$P($G(^PRC(442,PODA,1)),"^",15),FY=$E(%,3)+$E(%,4) S:$L(FY)=2 FY=$E(FY,2)
- ; get partial or final
- S PARTIAL=$P($G(^PRC(442,PODA,11,+$G(PARTLDA),0)),"^",9),PARTIAL=$S(PARTIAL="Y":" ",1:"P")
- ; get special fund control point and determine code sheet type
- S SFCP=$P($G(^PRC(442,PODA,0)),"^",19)
- I SOURCE=1,SFCP=2 D TYPE Q:%<0 I %'=1 D 551 Q
- I SFCP'=2 Q
- ; get releasing facility and payable indicator
- S %=$G(^PRC(442,PODA,18)),RELESFAC=$P(%,"^"),PAYABLE=$P(%,"^",2) S:RELESFAC="" RELESFAC=" " S:PAYABLE="" PAYABLE="A"
- ; build code sheets
- K ^TMP($J,"STRING") S TRANREG=0,COUNT=1 F S TRANREG=$O(^PRCP(445.2,"C",PONO,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)_$E(DATE,6,7)
- . 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) I $E($P(ITEMDATA,"^",5),1,4)=6505 D S DESC=$E(DESC,1,8)_"D"_NDC
- . . S %=$P($G(^PRC(441,+$P(DATA,"^",5),2,+$P($G(^PRC(442,PODA,1)),"^"),0)),"^",5),X1=$P(%,"-"),X2=$P(%,"-",2),X3=$P(%,"-",3),NDC=$E("000000",$L(X1)+1,6)_X1_$E("0000",$L(X2)+1,4)_X2_$E("00",$L(X3)+1,2)_X3
- . ; get qty and total value
- . S QTY=$P(DATA,"^",7),COST=$TR($J($P(DATA,"^",22),0,2),"."),COST=$E("0000000",$L(COST)+1,7)_COST,QTY=$E("00000",$L(QTY)+1,5)_QTY
- . S ^TMP($J,"STRING",COUNT)=NSN_$P(PONO,"-")_6321_SOURCE_DESC_UI_$S(SOURCE=0!(SOURCE=1):DOCID,1:" ")_COST_" "_SRCEDEV_PARTIAL_QTY_DOCID_RELESFAC_PAYABLE_FY_DATEREC,COUNT=COUNT+1
- I COUNT=1 Q
- D TRANSMIT^PRCPSMCL($P(PONO,"-"),632,"LOG")
- W !!?4,"LOG 632 Transmitted in MailMan Messages:" I $D(PRCPXMZ) S %=0 F S %=$O(PRCPXMZ(%)) Q:'% W " ",PRCPXMZ(%)," "
- Q
- ;
- ;
- 551 ; create and transmit 551 code sheet
- ; $g(prcpflag) is true if incorrect response to depot
- ; number question.
- N DEPOT,REQNO,VOUCHER
- S DEPOT=$P($G(^PRC(442,PODA,18)),"^")
- S VOUCHER=$P($G(^PRC(442,PODA,1)),"^",13) I '$G(PRCPFLAG) D ASKVOUCH^PRCPSLOI I $G(PRCPFLAG) W !,$$ERROR^PRCPSLOR
- S REQNO=$P($G(^PRC(442,PODA,18)),"^",10),REQNO=$TR($P(REQNO,"-",2,3),"-") I REQNO="",'$G(PRCPFLAG) D ASKREQNO^PRCPSLOI I $G(PRCPFLAG) W !,$$ERROR^PRCPSLOR
- K ^TMP($J,"STRING") S ^TMP($J,"STRING",1)=DEPOT_VOUCHER_REQNO_$P(PONO,"-")_551_" "_FY_"R"_" "_DOCID_" "
- D TRANSMIT^PRCPSMCL($P(PONO,"-"),551,"LOG")
- W !!?4,"LOG 551 Transmitted in MailMan Messages:" I $D(PRCPXMZ) S %=0 F S %=$O(PRCPXMZ(%)) Q:'% W " ",PRCPXMZ(%)," "
- Q
- ;
- ;
- TYPE ; ask if fastrac or usexpress
- S XP="Is this a FASTRAC or US EXPRESS order",XH="Enter 'YES' to generate the 632 code sheet, 'NO' to generate the 551 code sheet."
- S %=$$YN^PRCPUYN(2)
- Q
- ;
- ;
- ERROR() ; display error message
- Q "WARNING -- CODE SHEETS WILL PROBABLY REJECT AND HAVE TO BE RESUBMITTED."
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSLOR 4071 printed Feb 18, 2025@23:42:12 Page 2
- PRCPSLOR ;WISC/RFJ-receiving code sheets to log ;22 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 ; create/trans receiving code sheets to isms (log)
- +1 ; pono=purchase order number
- +2 ; tranid=transaction register id number
- +3 ; partlda=partial number (optional) - if set, can determine
- +4 ; if this receipt is a partial or final.
- +5 ; prc=standard variables defined (for creating code sheets)
- +6 NEW %,COST,COUNT,DATA,DATE,DATEREC,DESC,DISYS,DOCID,FY,ITEMDATA,NDC,NSN,PARTIAL,PAYABLE,PRCPXMZ,PODA,QTY,RELESFAC,SFCP,SOURCE,SRCEDEV,TRANREG,UI,X,X1,X2,X3
- +7 SET PODA=+$ORDER(^PRC(442,"B",PONO,0))
- SET SOURCE=+$PIECE($GET(^PRCD(420.8,+$PIECE($GET(^PRC(442,PODA,1)),"^",7),0)),"^")
- if SOURCE=""
- SET SOURCE=" "
- SET SRCEDEV=$PIECE($GET(^PRC(442,PODA,17)),"^",13)
- if SRCEDEV=""
- SET SRCEDEV=" "
- IF SOURCE="B"
- SET SOURCE=6
- +8 ; get document identifier
- +9 SET DOCID=$EXTRACT($PIECE(PONO,"-",2))_$EXTRACT($PIECE(PONO,"-",2),3,6)
- SET DOCID=$EXTRACT(" ",$LENGTH(DOCID)+1,5)_DOCID
- +10 ; get fiscal year of funding and date
- +11 SET %=+$PIECE($GET(^PRC(442,PODA,1)),"^",15)
- SET FY=$EXTRACT(%,3)+$EXTRACT(%,4)
- if $LENGTH(FY)=2
- SET FY=$EXTRACT(FY,2)
- +12 ; get partial or final
- +13 SET PARTIAL=$PIECE($GET(^PRC(442,PODA,11,+$GET(PARTLDA),0)),"^",9)
- SET PARTIAL=$SELECT(PARTIAL="Y":" ",1:"P")
- +14 ; get special fund control point and determine code sheet type
- +15 SET SFCP=$PIECE($GET(^PRC(442,PODA,0)),"^",19)
- +16 IF SOURCE=1
- IF SFCP=2
- DO TYPE
- if %<0
- QUIT
- IF %'=1
- DO 551
- QUIT
- +17 IF SFCP'=2
- QUIT
- +18 ; get releasing facility and payable indicator
- +19 SET %=$GET(^PRC(442,PODA,18))
- SET RELESFAC=$PIECE(%,"^")
- SET PAYABLE=$PIECE(%,"^",2)
- if RELESFAC=""
- SET RELESFAC=" "
- if PAYABLE=""
- SET PAYABLE="A"
- +20 ; build code sheets
- +21 KILL ^TMP($JOB,"STRING")
- SET TRANREG=0
- SET COUNT=1
- FOR
- SET TRANREG=$ORDER(^PRCP(445.2,"C",PONO,TRANREG))
- if 'TRANREG
- QUIT
- SET DATA=$GET(^PRCP(445.2,TRANREG,0))
- IF DATA'=""
- IF $PIECE(DATA,"^",2)=TRANID
- Begin DoDot:1
- +22 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)_$EXTRACT(DATE,6,7)
- +23 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)
- +24 SET DESC=$EXTRACT($PIECE(ITEMDATA,"^",2)_" ",1,21)
- IF $EXTRACT($PIECE(ITEMDATA,"^",5),1,4)=6505
- Begin DoDot:2
- +25 SET %=$PIECE($GET(^PRC(441,+$PIECE(DATA,"^",5),2,+$PIECE($GET(^PRC(442,PODA,1)),"^"),0)),"^",5)
- SET X1=$PIECE(%,"-")
- SET X2=$PIECE(%,"-",2)
- SET X3=$PIECE(%,"-",3)
- SET NDC=$EXTRACT("000000",$LENGTH(X1)+1,6)_X1_$EXTRACT("0000",$LENGTH(X2)+1,4)_X2_$EXTRACT("00",$LENGTH(X3)+1,2)_X3
- End DoDot:2
- SET DESC=$EXTRACT(DESC,1,8)_"D"_NDC
- +26 ; get qty and total value
- +27 SET QTY=$PIECE(DATA,"^",7)
- SET COST=$TRANSLATE($JUSTIFY($PIECE(DATA,"^",22),0,2),".")
- SET COST=$EXTRACT("0000000",$LENGTH(COST)+1,7)_COST
- SET QTY=$EXTRACT("00000",$LENGTH(QTY)+1,5)_QTY
- +28 SET ^TMP($JOB,"STRING",COUNT)=NSN_$PIECE(PONO,"-")_6321_SOURCE_DESC_UI_$SELECT(SOURCE=0!(SOURCE=1):DOCID,1:" ")_COST_" "_SRCEDEV_PARTIAL_QTY_DOCID_RELESFAC_PAYABLE_FY_DATEREC
- SET COUNT=COUNT+1
- End DoDot:1
- +29 IF COUNT=1
- QUIT
- +30 DO TRANSMIT^PRCPSMCL($PIECE(PONO,"-"),632,"LOG")
- +31 WRITE !!?4,"LOG 632 Transmitted in MailMan Messages:"
- IF $DATA(PRCPXMZ)
- SET %=0
- FOR
- SET %=$ORDER(PRCPXMZ(%))
- if '%
- QUIT
- WRITE " ",PRCPXMZ(%)," "
- +32 QUIT
- +33 ;
- +34 ;
- 551 ; create and transmit 551 code sheet
- +1 ; $g(prcpflag) is true if incorrect response to depot
- +2 ; number question.
- +3 NEW DEPOT,REQNO,VOUCHER
- +4 SET DEPOT=$PIECE($GET(^PRC(442,PODA,18)),"^")
- +5 SET VOUCHER=$PIECE($GET(^PRC(442,PODA,1)),"^",13)
- IF '$GET(PRCPFLAG)
- DO ASKVOUCH^PRCPSLOI
- IF $GET(PRCPFLAG)
- WRITE !,$$ERROR^PRCPSLOR
- +6 SET REQNO=$PIECE($GET(^PRC(442,PODA,18)),"^",10)
- SET REQNO=$TRANSLATE($PIECE(REQNO,"-",2,3),"-")
- IF REQNO=""
- IF '$GET(PRCPFLAG)
- DO ASKREQNO^PRCPSLOI
- IF $GET(PRCPFLAG)
- WRITE !,$$ERROR^PRCPSLOR
- +7 KILL ^TMP($JOB,"STRING")
- SET ^TMP($JOB,"STRING",1)=DEPOT_VOUCHER_REQNO_$PIECE(PONO,"-")_551_" "_FY_"R"_" "_DOCID_" "
- +8 DO TRANSMIT^PRCPSMCL($PIECE(PONO,"-"),551,"LOG")
- +9 WRITE !!?4,"LOG 551 Transmitted in MailMan Messages:"
- IF $DATA(PRCPXMZ)
- SET %=0
- FOR
- SET %=$ORDER(PRCPXMZ(%))
- if '%
- QUIT
- WRITE " ",PRCPXMZ(%)," "
- +10 QUIT
- +11 ;
- +12 ;
- TYPE ; ask if fastrac or usexpress
- +1 SET XP="Is this a FASTRAC or US EXPRESS order"
- SET XH="Enter 'YES' to generate the 632 code sheet, 'NO' to generate the 551 code sheet."
- +2 SET %=$$YN^PRCPUYN(2)
- +3 QUIT
- +4 ;
- +5 ;
- ERROR() ; display error message
- +1 QUIT "WARNING -- CODE SHEETS WILL PROBABLY REJECT AND HAVE TO BE RESUBMITTED."