- PRCHFPT3 ;WISC/RSD/RHD-CONT. OF PRINT ;7/21/99 13:19
- V ;;5.1;IFCAP;**221**;Oct 20, 2000;Build 14
- ;Per VA Directive 6204, this routine should not be modified.
- ;PRC*5.1*221 Modify an item description display to skip '|' logic
- ; if description contains a undefined display command
- ; like '| IN '
- ;
- ITEM N PURPIPE,PRCHDIW,PRCHI,PRCHJ ;PRC*5.1*221
- S DIWL=1,DIWR=33,DIWF="" K ^UTILITY($J,"W")
- S PURPIPE=0 D PIPECK S PRCHD=0 ;PRC*5.1*221
- F PRCHJJ=0:0 S PRCHD=$O(^PRC(442,D0,2,PRCH,1,PRCHD)) Q:PRCHD="" S X=$G(^(PRCHD,0)) S:PURPIPE DIWF=$G(DIWF)_"|" D DIWP^PRCUTL($G(DA)) ;PRC*5.1*221
- K ^TMP($J,"W") S %X="^UTILITY($J,""W"",1,",%Y="^TMP($J,""W"",1," D %XY^%RCR
- K PRCHJJ S PRCHCNT=$G(^UTILITY($J,"W",1)),PRCHL=PRCHL+PRCHCNT+1 W !?2,$J(+$P(PRCHI0,U,1),3),?7,$G(^(1,1,0))
- I PRCHTYPE'="S" W ?42,$J($P(PRCHI0,U,2),7),?52,$P($G(^PRCD(420.5,+$P(PRCHI0,U,3),0)),U,1) D
- . S X=$P($P(PRCHI0,U,9),".",2) W ?55,$S($L(X)>3:$J($P(PRCHI0,U,9),8,4),$L(X)>2:$J($P(PRCHI0,U,9),8,3),$P(PRCHI0,U,9)="N/C":" N/C",1:$J($P(PRCHI0,U,9),8,2))
- D AMT
- I PRCHCNT>1 F K=2:1:$P(^TMP($J,"P",P,PRCH),U,2) W:$D(^TMP($J,"W",1,K,0)) !?8,^(0)
- W ! S PRCHL=PRCHL+1 I $P(PRCHI0,U,6)]"" W ?8,"STK#: ",$P(PRCHI0,U,6),! S PRCHL=PRCHL+1
- I $P(PRCHI0,U,13)]"" W ?8,"NSN: ",$P(PRCHI0,U,13) D:$D(PRCHNRQ) PSNO^PRCHFPNT W ! S PRCHL=PRCHL+1
- I $P($G(^PRC(442,D0,2,PRCH,4)),U,12)]"" W ?8,"FOOD GROUP: ",$P(^(4),U,12),! S PRCHL=PRCHL+1
- D EDISTAT^PRCHUTL(D0,PRCH,.PRCHL)
- I PRCHDES="R",$P(PRCHI0,U,5)]"" W ?8,"IMF#: ",$P(PRCHI0,U,5)_" "
- I $P(PRCHI0,U,12),PRCHTYPE'="S" W:$P(PRCHI0,U,5)']""!($P(PRCHI0,U,5)]""&(PRCHDES'="R")) ?8 W "Items per ",$P($G(^PRCD(420.5,+$P(PRCHI0,U,3),0)),U,1),": ",$P(PRCHI0,U,12),! S PRCHL=PRCHL+1
- W ?8,"BOC: ",$P($P(PRCHI0,U,4)," ",1) S FMSLN=$O(^PRC(442,D0,22,"B",+$P(PRCHI0,U,4),0)) S PRCHL=PRCHL+1
- I FMSLN>0,PRCHTYPE'="S" S FMSLN="00"_$P($G(^PRC(442,D0,22,FMSLN,0)),U,3),FMSLN=$E(FMSLN,$L(FMSLN)-2,99) W ?22,"FMS LINE: ",FMSLN
- W:$P(PRCHI2,U,2)]"" ?40,"CONTRACT: ",$P(PRCHI2,U,2)
- W ! S PRCHL=PRCHL+1
- Q
- ;
- AMT W ?66,$J($P(PRCHI2,U,1),8,2) S PRCHC=0,PRCHPT=PRCHPT+$P(PRCHI2,U,1),X=$O(^PRC(442,D0,2,PRCH,3,"AC",PRCHFPT,0))
- I PRCHDES="R",X,$D(^PRC(442,D0,2,PRCH,3,X,0)) W ?76,$J($P(^(0),U,2),7),?86,$J($P(^(0),U,3),8,2)
- Q
- ;
- AUTH W !,"AUTHORITY FOR PURCHASE",?28,$S($D(PRCHNRQ):"REQ.",1:"P.O.")_" NO.",?42,$S($D(PRCHNRQ):"REQ.",1:"PO ")_"DATE" S Y=$P($G(^PRC(442,D0,7)),U,3) W:Y="Y" ?54,"EST." W ?59,"TOTAL: ",?66,$J($P(PRCH0,U,15),8,2)
- I PRCHDES="R",PRCHDA W ?76,"DSCNT AMT: ",$J(PRCHDA,8,2) S PRCHDTA=PRCHDTA-PRCHDA
- W !?2 S Y=0 F I=1:1 S Y=$O(^PRC(442,D0,14,Y)) Q:'Y W:I>1 "," W $P($G(^PRC(442.4,+^(Y,0),0)),U,2)
- I $D(PRCHNRQ) W ?8,"P.O.# "_$P(PRCH0,U,1),?28 W:$D(^PRC(442,D0,18)) $P(^(18),U,10)
- W:'$D(PRCHNRQ) ?28,$P(PRCH0,U,1) W ?42 S Y=$P(PRCH1,U,15) D DT
- W:PRCHDES="R"&PRCHDTA ?76,"TOTAL AMT:",$J(PRCHDTA,10,2)
- D FAXEMAIL(+$P($G(PRCH1),U,10),.PRCFAX,.PRCEMAIL)
- W !,$S(PRCHTYPE'="":"AUTHORIZED BUYER",1:"CONTRACTING OFFICER"),?35,"DATE SIGNED",?52,"PHONE" W:PRCFAX'="" ?70,"FAX"
- I PRCHDES="R",$D(^PRC(442,D0,11,PRCHFPT,0)) S X=$P(^(0),U,3)+$P(^(0),U,5) W:PRCHDTA-X ?76,"TERM DSCNT: ",$J(PRCHDTA-X,8,2) S PRCHDA=X
- S P=+$P(PRCH1,U,10),Y=$P($G(^PRC(442,D0,12)),U,3) W !,"/ES/"_$$DECODE^PRCHES5(D0)
- W ?35 D DT,DT1 W:$D(^VA(200,P,.13)) ?52,$P(^(.13),U,5),?70,PRCFAX
- I (PRCEMAIL'="")!(PRCHDES="R"&(PRCHDTA-PRCHDA)) D
- . W ! W:PRCEMAIL'="" "E-MAIL: ",PRCEMAIL
- . W:PRCHDES="R"&(PRCHDTA-PRCHDA) ?76,"NET AMT: ",$J(PRCHDA,10,2)
- K PRCFAX,PRCEMAIL W !,PRCHULN
- ;
- APP W !,?7,"FUND CERTIFICATION: The supplies/services listed on this request are properly",!?5,"chargeable to the following allotments, the available balances of which are"
- W !?5,"sufficient to cover the cost thereof, and funds have been obligated."
- W !,"APPROPRIATION: ",$P(PRCH0,U,4),"-",$P($P(PRCH0,U,3)," ",1),?40,"OBLIGATED BY: " S (X,Y)="",P=0 I $D(^PRC(442,D0,10,1,0)) S Y=$P(^(0),U,6),P=+$P(^(0),U,2),X=$P(^(0),U,5)
- I X]"" W "/ES/"_$$DECODE^PRCHES4(D0,1),?75,"DATE: " D:Y]"" DT
- I X="",$D(^VA(200,+P,0)) S X=$P(^(0),"^",1) W $P(X,",",2)," ",$P(X,",",1),?75,"DATE: " D:Y]"" DT
- K BOC S CHGSHP=$P($G(^PRC(442,D0,0)),U,13),BOC=0,CNT=1,BOCCT=$G(^PRC(442,D0,22,0)),BOCCT=$P(BOCCT,U,4) S:CHGSHP'>0 BOCCT=BOCCT-1 I BOCCT'>0 G APP1
- F Q:CNT>2 S BOC=$O(^PRC(442,D0,22,BOC)) Q:BOC'>0 S BOC22=$G(^(BOC,0)) I $P(BOC22,U,3)'=991 S BOC(CNT)=BOC22,CNT=CNT+1
- S PZZBOC=BOC_"^"_CNT
- APP1 W !,"COST CENTER: ",$P(PRCH0,U,5)
- I $D(BOC(1)) W ?41,"BOC1:",?48,$P(BOC(1),U),?56,"AMOUNT1:",?66,$J($P(BOC(1),U,2),12,2),?80 S FMSLN="00"_$P(BOC(1),U,3),FMSLN=$E(FMSLN,$L(FMSLN)-2,99) W "FMS LINE: ",FMSLN
- S Y=$G(^PRCD(420.8,+$P(PRCH1,U,7),0))
- W !,"SOURCE CODE: " S X=$P(Y,U,1) W "SUPPLY-"_$S(X="B":"COMB.2,4,6",1:X_" ") S X=$P(Y,U,3) W " FISCAL-" W:X X
- I $D(BOC(2)) W ?41,"BOC2:",?48,$P(BOC(2),U),?56,"AMOUNT2:",?66,$J($P(BOC(2),U,2),12,2),?80 S FMSLN="00"_$P(BOC(2),U,3),FMSLN=$E(FMSLN,$L(FMSLN)-2,99) W "FMS LINE: ",FMSLN
- I CHGSHP>0&('$D(BOC(2))) W ?41,"BOC2:",?48,+$P($G(^PRC(442,D0,23)),U),?56,"AMOUNT2:",?66,$J(CHGSHP,12,2),?80,"FMS LINE: 991" S PRCHL=PRCHL+1
- D SETUP^PRCHFPT4
- W !,"FCP/PRJ: ",PRCHPRJ,?41,$S(P>1&(BOCCT>2):"**ADDITIONAL BOCs WILL BE FOUND AFTER ALL THE ITEMS.**",BOCCT>2:"**ADDITIONAL BOCs WILL BE FOUND ON THE NEXT PAGE.**",1:"")
- K PRCHZ0,PRCHZ1,PRCHSTN,PRCHFCP,PRC("BBFY"),PODATE,MO,PRCHB,PRCHPRJ
- W !
- Q
- ;
- DT W:Y Y\100#100,"/",Y#100\1,"/",Y\10000+1700
- Q
- ;
- DT1 Q:'Y S Y=$P(Y,".",2),Y=Y_$E("0000",1,(4-$L(Y))) Q:'Y W "@",$E(Y,1,2),":",$E(Y,3,4)
- Q
- ;1st argument is passed internal entry number of person
- ;2nd argument is returned Fax Number
- ;3rd argument is returned e-mail address
- FAXEMAIL(PRCA,PRCB,PRCC) ;
- I PRCA'>0 S PRCB="",PRCC="" Q
- I '$D(^VA(200,PRCA)) S PRCB="",PRCC="" Q
- N PRCX,DIC,DR,DA,DIQ,D0 K ^UTILITY("DIQ1",$J)
- S DIC=200,DR=".136;.151",DA=PRCA,DIQ="PRCX",DIQ(0)="I" D EN^DIQ1
- S PRCB=PRCX(200,DA,.136,"I"),PRCC=PRCX(200,DA,.151,"I") K ^UTILITY("DIQ1",$J)
- Q
- PIPECK ;check for invalid pipe '|IN ' command in item description ;PRC*5.1*221
- N PRCHWD,PRCHX S PRCHWD=0
- F S PRCHWD=$O(^PRC(442,D0,2,PRCH,1,PRCHWD)) Q:PRCHWD'>0 D Q:PURPIPE
- . S PRCHX=$S($D(^(PRCHWD,0)):^(0),1:"")
- . I PRCHX["| IN " S PURPIPE=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPT3 6243 printed Feb 18, 2025@23:34:03 Page 2
- PRCHFPT3 ;WISC/RSD/RHD-CONT. OF PRINT ;7/21/99 13:19
- V ;;5.1;IFCAP;**221**;Oct 20, 2000;Build 14
- +1 ;Per VA Directive 6204, this routine should not be modified.
- +2 ;PRC*5.1*221 Modify an item description display to skip '|' logic
- +3 ; if description contains a undefined display command
- +4 ; like '| IN '
- +5 ;
- ITEM ;PRC*5.1*221
- NEW PURPIPE,PRCHDIW,PRCHI,PRCHJ
- +1 SET DIWL=1
- SET DIWR=33
- SET DIWF=""
- KILL ^UTILITY($JOB,"W")
- +2 ;PRC*5.1*221
- SET PURPIPE=0
- DO PIPECK
- SET PRCHD=0
- +3 ;PRC*5.1*221
- FOR PRCHJJ=0:0
- SET PRCHD=$ORDER(^PRC(442,D0,2,PRCH,1,PRCHD))
- if PRCHD=""
- QUIT
- SET X=$GET(^(PRCHD,0))
- if PURPIPE
- SET DIWF=$GET(DIWF)_"|"
- DO DIWP^PRCUTL($GET(DA))
- +4 KILL ^TMP($JOB,"W")
- SET %X="^UTILITY($J,""W"",1,"
- SET %Y="^TMP($J,""W"",1,"
- DO %XY^%RCR
- +5 KILL PRCHJJ
- SET PRCHCNT=$GET(^UTILITY($JOB,"W",1))
- SET PRCHL=PRCHL+PRCHCNT+1
- WRITE !?2,$JUSTIFY(+$PIECE(PRCHI0,U,1),3),?7,$GET(^(1,1,0))
- +6 IF PRCHTYPE'="S"
- WRITE ?42,$JUSTIFY($PIECE(PRCHI0,U,2),7),?52,$PIECE($GET(^PRCD(420.5,+$PIECE(PRCHI0,U,3),0)),U,1)
- Begin DoDot:1
- +7 SET X=$PIECE($PIECE(PRCHI0,U,9),".",2)
- WRITE ?55,$SELECT($LENGTH(X)>3:$JUSTIFY($PIECE(PRCHI0,U,9),8,4),$LENGTH(X)>2:$JUSTIFY($PIECE(PRCHI0,U,9),8,3),$PIECE(PRCHI0,U,9)="N/C":" N/C",1:$JUSTIFY($PIECE(PRCHI0,U,9),8,2))
- End DoDot:1
- +8 DO AMT
- +9 IF PRCHCNT>1
- FOR K=2:1:$PIECE(^TMP($JOB,"P",P,PRCH),U,2)
- if $DATA(^TMP($JOB,"W",1,K,0))
- WRITE !?8,^(0)
- +10 WRITE !
- SET PRCHL=PRCHL+1
- IF $PIECE(PRCHI0,U,6)]""
- WRITE ?8,"STK#: ",$PIECE(PRCHI0,U,6),!
- SET PRCHL=PRCHL+1
- +11 IF $PIECE(PRCHI0,U,13)]""
- WRITE ?8,"NSN: ",$PIECE(PRCHI0,U,13)
- if $DATA(PRCHNRQ)
- DO PSNO^PRCHFPNT
- WRITE !
- SET PRCHL=PRCHL+1
- +12 IF $PIECE($GET(^PRC(442,D0,2,PRCH,4)),U,12)]""
- WRITE ?8,"FOOD GROUP: ",$PIECE(^(4),U,12),!
- SET PRCHL=PRCHL+1
- +13 DO EDISTAT^PRCHUTL(D0,PRCH,.PRCHL)
- +14 IF PRCHDES="R"
- IF $PIECE(PRCHI0,U,5)]""
- WRITE ?8,"IMF#: ",$PIECE(PRCHI0,U,5)_" "
- +15 IF $PIECE(PRCHI0,U,12)
- IF PRCHTYPE'="S"
- if $PIECE(PRCHI0,U,5)']""!($PIECE(PRCHI0,U,5)]""&(PRCHDES'="R"))
- WRITE ?8
- WRITE "Items per ",$PIECE($GET(^PRCD(420.5,+$PIECE(PRCHI0,U,3),0)),U,1),": ",$PIECE(PRCHI0,U,12),!
- SET PRCHL=PRCHL+1
- +16 WRITE ?8,"BOC: ",$PIECE($PIECE(PRCHI0,U,4)," ",1)
- SET FMSLN=$ORDER(^PRC(442,D0,22,"B",+$PIECE(PRCHI0,U,4),0))
- SET PRCHL=PRCHL+1
- +17 IF FMSLN>0
- IF PRCHTYPE'="S"
- SET FMSLN="00"_$PIECE($GET(^PRC(442,D0,22,FMSLN,0)),U,3)
- SET FMSLN=$EXTRACT(FMSLN,$LENGTH(FMSLN)-2,99)
- WRITE ?22,"FMS LINE: ",FMSLN
- +18 if $PIECE(PRCHI2,U,2)]""
- WRITE ?40,"CONTRACT: ",$PIECE(PRCHI2,U,2)
- +19 WRITE !
- SET PRCHL=PRCHL+1
- +20 QUIT
- +21 ;
- AMT WRITE ?66,$JUSTIFY($PIECE(PRCHI2,U,1),8,2)
- SET PRCHC=0
- SET PRCHPT=PRCHPT+$PIECE(PRCHI2,U,1)
- SET X=$ORDER(^PRC(442,D0,2,PRCH,3,"AC",PRCHFPT,0))
- +1 IF PRCHDES="R"
- IF X
- IF $DATA(^PRC(442,D0,2,PRCH,3,X,0))
- WRITE ?76,$JUSTIFY($PIECE(^(0),U,2),7),?86,$JUSTIFY($PIECE(^(0),U,3),8,2)
- +2 QUIT
- +3 ;
- AUTH WRITE !,"AUTHORITY FOR PURCHASE",?28,$SELECT($DATA(PRCHNRQ):"REQ.",1:"P.O.")_" NO.",?42,$SELECT($DATA(PRCHNRQ):"REQ.",1:"PO ")_"DATE"
- SET Y=$PIECE($GET(^PRC(442,D0,7)),U,3)
- if Y="Y"
- WRITE ?54,"EST."
- WRITE ?59,"TOTAL: ",?66,$JUSTIFY($PIECE(PRCH0,U,15),8,2)
- +1 IF PRCHDES="R"
- IF PRCHDA
- WRITE ?76,"DSCNT AMT: ",$JUSTIFY(PRCHDA,8,2)
- SET PRCHDTA=PRCHDTA-PRCHDA
- +2 WRITE !?2
- SET Y=0
- FOR I=1:1
- SET Y=$ORDER(^PRC(442,D0,14,Y))
- if 'Y
- QUIT
- if I>1
- WRITE ","
- WRITE $PIECE($GET(^PRC(442.4,+^(Y,0),0)),U,2)
- +3 IF $DATA(PRCHNRQ)
- WRITE ?8,"P.O.# "_$PIECE(PRCH0,U,1),?28
- if $DATA(^PRC(442,D0,18))
- WRITE $PIECE(^(18),U,10)
- +4 if '$DATA(PRCHNRQ)
- WRITE ?28,$PIECE(PRCH0,U,1)
- WRITE ?42
- SET Y=$PIECE(PRCH1,U,15)
- DO DT
- +5 if PRCHDES="R"&PRCHDTA
- WRITE ?76,"TOTAL AMT:",$JUSTIFY(PRCHDTA,10,2)
- +6 DO FAXEMAIL(+$PIECE($GET(PRCH1),U,10),.PRCFAX,.PRCEMAIL)
- +7 WRITE !,$SELECT(PRCHTYPE'="":"AUTHORIZED BUYER",1:"CONTRACTING OFFICER"),?35,"DATE SIGNED",?52,"PHONE"
- if PRCFAX'=""
- WRITE ?70,"FAX"
- +8 IF PRCHDES="R"
- IF $DATA(^PRC(442,D0,11,PRCHFPT,0))
- SET X=$PIECE(^(0),U,3)+$PIECE(^(0),U,5)
- if PRCHDTA-X
- WRITE ?76,"TERM DSCNT: ",$JUSTIFY(PRCHDTA-X,8,2)
- SET PRCHDA=X
- +9 SET P=+$PIECE(PRCH1,U,10)
- SET Y=$PIECE($GET(^PRC(442,D0,12)),U,3)
- WRITE !,"/ES/"_$$DECODE^PRCHES5(D0)
- +10 WRITE ?35
- DO DT
- DO DT1
- if $DATA(^VA(200,P,.13))
- WRITE ?52,$PIECE(^(.13),U,5),?70,PRCFAX
- +11 IF (PRCEMAIL'="")!(PRCHDES="R"&(PRCHDTA-PRCHDA))
- Begin DoDot:1
- +12 WRITE !
- if PRCEMAIL'=""
- WRITE "E-MAIL: ",PRCEMAIL
- +13 if PRCHDES="R"&(PRCHDTA-PRCHDA)
- WRITE ?76,"NET AMT: ",$JUSTIFY(PRCHDA,10,2)
- End DoDot:1
- +14 KILL PRCFAX,PRCEMAIL
- WRITE !,PRCHULN
- +15 ;
- APP WRITE !,?7,"FUND CERTIFICATION: The supplies/services listed on this request are properly",!?5,"chargeable to the following allotments, the available balances of which are"
- +1 WRITE !?5,"sufficient to cover the cost thereof, and funds have been obligated."
- +2 WRITE !,"APPROPRIATION: ",$PIECE(PRCH0,U,4),"-",$PIECE($PIECE(PRCH0,U,3)," ",1),?40,"OBLIGATED BY: "
- SET (X,Y)=""
- SET P=0
- IF $DATA(^PRC(442,D0,10,1,0))
- SET Y=$PIECE(^(0),U,6)
- SET P=+$PIECE(^(0),U,2)
- SET X=$PIECE(^(0),U,5)
- +3 IF X]""
- WRITE "/ES/"_$$DECODE^PRCHES4(D0,1),?75,"DATE: "
- if Y]""
- DO DT
- +4 IF X=""
- IF $DATA(^VA(200,+P,0))
- SET X=$PIECE(^(0),"^",1)
- WRITE $PIECE(X,",",2)," ",$PIECE(X,",",1),?75,"DATE: "
- if Y]""
- DO DT
- +5 KILL BOC
- SET CHGSHP=$PIECE($GET(^PRC(442,D0,0)),U,13)
- SET BOC=0
- SET CNT=1
- SET BOCCT=$GET(^PRC(442,D0,22,0))
- SET BOCCT=$PIECE(BOCCT,U,4)
- if CHGSHP'>0
- SET BOCCT=BOCCT-1
- IF BOCCT'>0
- GOTO APP1
- +6 FOR
- if CNT>2
- QUIT
- SET BOC=$ORDER(^PRC(442,D0,22,BOC))
- if BOC'>0
- QUIT
- SET BOC22=$GET(^(BOC,0))
- IF $PIECE(BOC22,U,3)'=991
- SET BOC(CNT)=BOC22
- SET CNT=CNT+1
- +7 SET PZZBOC=BOC_"^"_CNT
- APP1 WRITE !,"COST CENTER: ",$PIECE(PRCH0,U,5)
- +1 IF $DATA(BOC(1))
- WRITE ?41,"BOC1:",?48,$PIECE(BOC(1),U),?56,"AMOUNT1:",?66,$JUSTIFY($PIECE(BOC(1),U,2),12,2),?80
- SET FMSLN="00"_$PIECE(BOC(1),U,3)
- SET FMSLN=$EXTRACT(FMSLN,$LENGTH(FMSLN)-2,99)
- WRITE "FMS LINE: ",FMSLN
- +2 SET Y=$GET(^PRCD(420.8,+$PIECE(PRCH1,U,7),0))
- +3 WRITE !,"SOURCE CODE: "
- SET X=$PIECE(Y,U,1)
- WRITE "SUPPLY-"_$SELECT(X="B":"COMB.2,4,6",1:X_" ")
- SET X=$PIECE(Y,U,3)
- WRITE " FISCAL-"
- if X
- WRITE X
- +4 IF $DATA(BOC(2))
- WRITE ?41,"BOC2:",?48,$PIECE(BOC(2),U),?56,"AMOUNT2:",?66,$JUSTIFY($PIECE(BOC(2),U,2),12,2),?80
- SET FMSLN="00"_$PIECE(BOC(2),U,3)
- SET FMSLN=$EXTRACT(FMSLN,$LENGTH(FMSLN)-2,99)
- WRITE "FMS LINE: ",FMSLN
- +5 IF CHGSHP>0&('$DATA(BOC(2)))
- WRITE ?41,"BOC2:",?48,+$PIECE($GET(^PRC(442,D0,23)),U),?56,"AMOUNT2:",?66,$JUSTIFY(CHGSHP,12,2),?80,"FMS LINE: 991"
- SET PRCHL=PRCHL+1
- +6 DO SETUP^PRCHFPT4
- +7 WRITE !,"FCP/PRJ: ",PRCHPRJ,?41,$SELECT(P>1&(BOCCT>2):"**ADDITIONAL BOCs WILL BE FOUND AFTER ALL THE ITEMS.**",BOCCT>2:"**ADDITIONAL BOCs WILL BE FOUND ON THE NEXT PAGE.**",1:"")
- +8 KILL PRCHZ0,PRCHZ1,PRCHSTN,PRCHFCP,PRC("BBFY"),PODATE,MO,PRCHB,PRCHPRJ
- +9 WRITE !
- +10 QUIT
- +11 ;
- DT if Y
- WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
- +1 QUIT
- +2 ;
- DT1 if 'Y
- QUIT
- SET Y=$PIECE(Y,".",2)
- SET Y=Y_$EXTRACT("0000",1,(4-$LENGTH(Y)))
- if 'Y
- QUIT
- WRITE "@",$EXTRACT(Y,1,2),":",$EXTRACT(Y,3,4)
- +1 QUIT
- +2 ;1st argument is passed internal entry number of person
- +3 ;2nd argument is returned Fax Number
- +4 ;3rd argument is returned e-mail address
- FAXEMAIL(PRCA,PRCB,PRCC) ;
- +1 IF PRCA'>0
- SET PRCB=""
- SET PRCC=""
- QUIT
- +2 IF '$DATA(^VA(200,PRCA))
- SET PRCB=""
- SET PRCC=""
- QUIT
- +3 NEW PRCX,DIC,DR,DA,DIQ,D0
- KILL ^UTILITY("DIQ1",$JOB)
- +4 SET DIC=200
- SET DR=".136;.151"
- SET DA=PRCA
- SET DIQ="PRCX"
- SET DIQ(0)="I"
- DO EN^DIQ1
- +5 SET PRCB=PRCX(200,DA,.136,"I")
- SET PRCC=PRCX(200,DA,.151,"I")
- KILL ^UTILITY("DIQ1",$JOB)
- +6 QUIT
- PIPECK ;check for invalid pipe '|IN ' command in item description ;PRC*5.1*221
- +1 NEW PRCHWD,PRCHX
- SET PRCHWD=0
- +2 FOR
- SET PRCHWD=$ORDER(^PRC(442,D0,2,PRCH,1,PRCHWD))
- if PRCHWD'>0
- QUIT
- Begin DoDot:1
- +3 SET PRCHX=$SELECT($DATA(^(PRCHWD,0)):^(0),1:"")
- +4 IF PRCHX["| IN "
- SET PURPIPE=1
- End DoDot:1
- if PURPIPE
- QUIT
- +5 QUIT
