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 Apr 09, 2024@21:17:31 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
