- PRCHFPT1 ;WISC/RSD/RHD-CONT. OF PRINT ;5/1/98 15:59
- ;;5.1;IFCAP;**143**;Oct 20, 2000;Build 3
- ;Per VHA Directive 2004-038, this routine should not be modified.
- I $P($G(^PRC(442,D0,24)),U,3)="RMPR" D K RMPRPO,RMPR664,RMPRR3
- . S RMPRPO=$P($P($G(^PRC(442,D0,0)),U),"-",2) Q:RMPRPO=""
- . S RMPR664=$O(^RMPR(664,"G",RMPRPO,0)) Q:RMPR664'>0
- . S RMPRR3=$G(^RMPR(664,RMPR664,3)) I $P(RMPRR3,U)="",$P(RMPRR3,U,4)="" Q
- . W !,"Prosthetics Delivery information:"
- . W !,?7,"Delivery To: ",$P(RMPRR3,U)
- . W !,?9,"Attention: ",$P(RMPRR3,U,4)
- . W ?96 F I=1:1:96 W @IOBS
- . W PRCHULN
- S Y=0 I PRCHDES="R",PRCHFPT,$D(^PRC(442,D0,11,PRCHFPT,0)),$P(^(0),U,12)]"" S X=^(0) D RR^PRCHFPT4
- D:'Y INV W !,"FOB POINT: ",$S("O"=$E($P(PRCH1,U,6)):"ORIGIN","D"=$E($P(PRCH1,U,6)):"DESTINATION",1:""),?34,"|","PROPOSAL: " S DIWL=1,DIWR=16,DIWF="",X=$P(PRCH1,U,8) K ^UTILITY($J,"W") D DIWP^PRCUTL($G(DA))
- K ^TMP($J,"W") S %X="^UTILITY($J,""W"",DIWL,",%Y="^TMP($J,""W"",DIWL," D %XY^%RCR
- W ?45,$G(^TMP($J,"W",1,1,0)),?64,"|",PRCHINV(1),!,"GOV'T BL #: ",$P(PRCH12,U,7),?34,"|",?45,$G(^TMP($J,"W",1,2,0)),?64,"|",PRCHINV(2)
- W !,$P(PRCH1,U,14) D TY W X,?34,"|",?45,$G(^TMP($J,"W",1,3,0)),?64,"|",PRCHINV(3)
- W !,"DELIVER ON/BEFORE " S Y=$P(PRCH0,U,10) D DT W ?34,"|","CONTRACT: "
- W ?64,"|",PRCHINV(4),!
- W "DISCOUNT TERM: " S PRCH=0 I $D(^PRC(442,D0,5,0)) F I=1:1:2 S PRCH=$O(^PRC(442,D0,5,PRCH)) Q:PRCH=""!(PRCH'>0) W $P(^(PRCH,0),U,4),$P(^(0),U,1) W:$P(^(0),U,1)=+$P(^(0),U,1) "%" W $P(^(0),U,2)," "
- K Y S PRCH=0
- F I=1:1:3 S:PRCH'="" PRCH=$O(^PRC(442,D0,2,"AC",PRCH)) S:PRCH'="" Y=$O(^(PRCH,0)) W:I=2 "SHIP VIA: ",$P(PRCH12,U,8) W ?34,"|" W:$G(Y)'="" ?42,$S($D(^(Y)):$J(^(Y),3),1:"") W:PRCH'="" ?45,PRCH W ?64,"|" D ; <<< rew
- .W:$D(PRCHINV(I+4)) PRCHINV(I+4) W ! K Y
- W $E(PRCHULN,1,34),"|",$E(PRCHULN,1,29),"|",$E(PRCHULN,1,31)
- W ! W:$G(PRCHTYPE)'="S" ?59,"UNIT" W ?69,"TOTAL" W:PRCHDES="R" ?80,"QTY",?90,"AMT"
- W !,"ITEM",?15,"DESCRIPTION" W:$G(PRCHTYPE)'="S" ?46,"QTY",?51,"UNIT",?59,"COST" W ?69,"COST"
- W:PRCHDES="R" ?80,"REC",?90,"REC" W ?96 F I=1:1:96 W @IOBS
- W PRCHULN K PRCHHSP,PRCHINV,PRCHSHP,PRCHST,S,V,^TMP($J,"P") S PRCHL=18,P=1,PRCH=0
- ;
- CNTI S PRCH=$O(^PRC(442,D0,2,PRCH)) G:PRCH'>0 CNTD S LITEM=$G(^(PRCH,2)),PRCHLB=1,PRCHL1=$P(LITEM,U,4) S:$P(^(0),U,6)]"" PRCHL1=PRCHL1+1 S:$P(^(0),U,13)]"" PRCHL1=PRCHL1+1 S:$P(LITEM,U,9)]"" PRCHL1=PRCHL1+1 S:$P(LITEM,U,11)]"" PRCHL1=PRCHL1+1
- S:$P($G(^PRC(442,D0,2,PRCH,2)),U,9)]""!($P($G(^(2)),U,11)]"") PRCHL1=PRCHL1+3 S:$P($G(^PRC(442,D0,2,PRCH,4)),U,12) PRCHL1=PRCHL1+1 S:P=1 PRCHL1=PRCHL1+3
- D P:PRCHL-1<1 S ^TMP($J,"P",P,PRCH)=PRCHLB_U_PRCHL1,PRCHL=PRCHL-PRCHL1-1
- G CNTI
- CNTD S (PRCHLE,PRCHLB,PRCH)=0 F J=0:0 S PRCH=$O(^PRC(442,D0,3,PRCH)) Q:PRCH=""!(PRCH'>0) S:PRCHLB=0 PRCHLB=PRCH S PRCHLE=PRCH D P1:PRCHL-2<1 S ^TMP($J,"P",P,"D")=PRCHLB_U_PRCHLE,PRCHL=PRCHL-2
- I $P(PRCH0,U,13)>0!($P(PRCH0,U,18)>0) D:PRCHL-3<1 P1 S ^TMP($J,"P",P,"E")=$P(PRCH0,U,13),PRCHL=PRCHL-3 I PRCHDES="R",PRCHDTA,PRCHFPT=1 S PRCHDTA=PRCHDTA+$P(PRCH0,U,13)
- I $D(^PRC(442,D0,15)) F J=0:0 S J=$O(^PRC(442,D0,15,J)) Q:'J S PRCHJ=^(J,0),PRCH="F"_J_U_+PRCHJ,PRCHLB=1,PRCHL1=$P(PRCHJ,U,2) D P:PRCHL-1<PRCHL1 S ^TMP($J,"P",P,PRCH)=PRCHLB_U_PRCHL1,PRCHL=PRCHL-PRCHL1-1
- G REQ:'$D(^PRC(442,D0,4,0)) K ^UTILITY($J,"W") S PRCH="W",DIWL=1,DIWR=64,DIWF="",PRCHJ=0 F S PRCHJ=$O(^PRC(442,D0,4,PRCHJ)) Q:PRCHJ="" S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
- K ^TMP($J,"PRCH") S %X="^UTILITY($J,""W"",DIWL,",%Y="^TMP($J,""PRCH"",1," D %XY^%RCR
- S PRCHL1=+^UTILITY($J,"W",DIWL),PRCHLB=1 D P:PRCHL-1<PRCHL1 S ^TMP($J,"P",P,"W")=PRCHLB_U_PRCHL1,PRCHL=PRCHL-PRCHL1-1
- ;
- REQ I $D(^PRC(442,D0,13,0)) S (PRCHLE,PRCHLB,PRCH)=0 F J=0:0 S PRCH=$O(^PRC(442,D0,13,PRCH)) Q:'PRCH S:PRCHLB=0 I=3,PRCHLB=PRCH S PRCHLE=PRCH D P1:PRCHL-I<3 S ^TMP($J,"P",P,"X")=PRCHLB_U_PRCHLE,PRCHL=PRCHL-I,I=2
- ;
- BOCLN S CHGSHP=$P($G(^PRC(442,D0,0)),U,13)
- S (N,COUNT)=0 I $G(^PRC(442,D0,22,0))'="" F S COUNT=$O(^PRC(442,D0,22,COUNT)) Q:COUNT=""!(COUNT'>0) S BCT=$G(^(COUNT,0)) I $P(BCT,U,3)'=991 S N=N+1
- S:CHGSHP>0 N=N+1
- S N=N-2 S:N<1 N=0
- S BOCPG=N\45,BOCPG=$S(N#45'=0:BOCPG+1,1:BOCPG) S:PRCHL-1<3 PRCHL=45 S P=P+BOCPG
- G ^PRCHFPT2
- ;
- P S PRCHL=45,P=P+1 Q
- ;
- P1 S PRCHLB=PRCHLE,PRCHL=45,P=P+1 Q
- ;
- DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700 Q
- Q
- ;
- TY S X=+$P(PRCH1,U,7),X=$P($G(^PRCD(420.8,X,0)),U,1),X=$S(X=2:"PURCHASE ORDER",X="B":"DELIVERY & PURCHASE ORDER",X="":"",1:"DELIVERY ORDER")
- Q
- ;
- INV ;
- I $P($G(^PRC(442,D0,0)),U,2)=25 D Q
- . N PRCA,PRCB,PRCC
- . S PRCHINV(1)="** No Purchase Card Info",PRCHINV(2)="",PRCHINV(3)="",PRCHINV(4)=""
- . S PRCA=$P($G(^PRC(442,D0,23)),U,8) Q:PRCA'>0
- . S PRCB=$G(^PRC(440.5,PRCA,0)) Q:PRCB=""
- . S PRCC=$P(PRCB,U,8) S:PRCC>0 PRCC=$P($G(^VA(200,PRCC,0)),U)
- . S PRCA=$P(PRCB,U,11),PRCHINV(1)="PURCHASE CARD HOLDER"
- . S PRCHINV(2)=" "_$E(PRCC,1,25),PRCHINV(3)="PURCHASE CARD NAME"
- . S PRCHINV(4)=" "_$E(PRCA,1,25)
- S PRCHINV(1)=" MAIL INVOICE TO:",PRCHINV(2)=" "_$P(PRCHINV,U,1),PRCHINV(3)=" "_$P(PRCHINV,U,2),X=4
- S:$P(PRCHINV,U,3)]"" PRCHINV(X)=" "_$P(PRCHINV,U,3),X=X+1 S:$P(PRCHINV,U,4)]"" PRCHINV(X)=" "_$P(PRCHINV,U,4),X=X+1
- S PRCHINV(X)=" "_$P(PRCHINV,U,5)_", "_$P($G(^DIC(5,+$P(PRCHINV,U,6),0)),U,2)_" "_$P(PRCHINV,U,7)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPT1 5231 printed Mar 13, 2025@21:12:26 Page 2
- PRCHFPT1 ;WISC/RSD/RHD-CONT. OF PRINT ;5/1/98 15:59
- +1 ;;5.1;IFCAP;**143**;Oct 20, 2000;Build 3
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 IF $PIECE($GET(^PRC(442,D0,24)),U,3)="RMPR"
- Begin DoDot:1
- +4 SET RMPRPO=$PIECE($PIECE($GET(^PRC(442,D0,0)),U),"-",2)
- if RMPRPO=""
- QUIT
- +5 SET RMPR664=$ORDER(^RMPR(664,"G",RMPRPO,0))
- if RMPR664'>0
- QUIT
- +6 SET RMPRR3=$GET(^RMPR(664,RMPR664,3))
- IF $PIECE(RMPRR3,U)=""
- IF $PIECE(RMPRR3,U,4)=""
- QUIT
- +7 WRITE !,"Prosthetics Delivery information:"
- +8 WRITE !,?7,"Delivery To: ",$PIECE(RMPRR3,U)
- +9 WRITE !,?9,"Attention: ",$PIECE(RMPRR3,U,4)
- +10 WRITE ?96
- FOR I=1:1:96
- WRITE @IOBS
- +11 WRITE PRCHULN
- End DoDot:1
- KILL RMPRPO,RMPR664,RMPRR3
- +12 SET Y=0
- IF PRCHDES="R"
- IF PRCHFPT
- IF $DATA(^PRC(442,D0,11,PRCHFPT,0))
- IF $PIECE(^(0),U,12)]""
- SET X=^(0)
- DO RR^PRCHFPT4
- +13 if 'Y
- DO INV
- WRITE !,"FOB POINT: ",$SELECT("O"=$EXTRACT($PIECE(PRCH1,U,6)):"ORIGIN","D"=$EXTRACT($PIECE(PRCH1,U,6)):"DESTINATION",1:""),?34,"|","PROPOSAL: "
- SET DIWL=1
- SET DIWR=16
- SET DIWF=""
- SET X=$PIECE(PRCH1,U,8)
- KILL ^UTILITY($JOB,"W")
- DO DIWP^PRCUTL($GET(DA))
- +14 KILL ^TMP($JOB,"W")
- SET %X="^UTILITY($J,""W"",DIWL,"
- SET %Y="^TMP($J,""W"",DIWL,"
- DO %XY^%RCR
- +15 WRITE ?45,$GET(^TMP($JOB,"W",1,1,0)),?64,"|",PRCHINV(1),!,"GOV'T BL #: ",$PIECE(PRCH12,U,7),?34,"|",?45,$GET(^TMP($JOB,"W",1,2,0)),?64,"|",PRCHINV(2)
- +16 WRITE !,$PIECE(PRCH1,U,14)
- DO TY
- WRITE X,?34,"|",?45,$GET(^TMP($JOB,"W",1,3,0)),?64,"|",PRCHINV(3)
- +17 WRITE !,"DELIVER ON/BEFORE "
- SET Y=$PIECE(PRCH0,U,10)
- DO DT
- WRITE ?34,"|","CONTRACT: "
- +18 WRITE ?64,"|",PRCHINV(4),!
- +19 WRITE "DISCOUNT TERM: "
- SET PRCH=0
- IF $DATA(^PRC(442,D0,5,0))
- FOR I=1:1:2
- SET PRCH=$ORDER(^PRC(442,D0,5,PRCH))
- if PRCH=""!(PRCH'>0)
- QUIT
- WRITE $PIECE(^(PRCH,0),U,4),$PIECE(^(0),U,1)
- if $PIECE(^(0),U,1)=+$PIECE(^(0),U,1)
- WRITE "%"
- WRITE $PIECE(^(0),U,2)," "
- +20 KILL Y
- SET PRCH=0
- +21 ; <<< rew
- FOR I=1:1:3
- if PRCH'=""
- SET PRCH=$ORDER(^PRC(442,D0,2,"AC",PRCH))
- if PRCH'=""
- SET Y=$ORDER(^(PRCH,0))
- if I=2
- WRITE "SHIP VIA: ",$PIECE(PRCH12,U,8)
- WRITE ?34,"|"
- if $GET(Y)'=""
- WRITE ?42,$SELECT($DATA(^(Y)):$JUSTIFY(^(Y),3),1:"")
- if PRCH'=""
- WRITE ?45,PRCH
- WRITE ?64,"|"
- Begin DoDot:1
- +22 if $DATA(PRCHINV(I+4))
- WRITE PRCHINV(I+4)
- WRITE !
- KILL Y
- End DoDot:1
- +23 WRITE $EXTRACT(PRCHULN,1,34),"|",$EXTRACT(PRCHULN,1,29),"|",$EXTRACT(PRCHULN,1,31)
- +24 WRITE !
- if $GET(PRCHTYPE)'="S"
- WRITE ?59,"UNIT"
- WRITE ?69,"TOTAL"
- if PRCHDES="R"
- WRITE ?80,"QTY",?90,"AMT"
- +25 WRITE !,"ITEM",?15,"DESCRIPTION"
- if $GET(PRCHTYPE)'="S"
- WRITE ?46,"QTY",?51,"UNIT",?59,"COST"
- WRITE ?69,"COST"
- +26 if PRCHDES="R"
- WRITE ?80,"REC",?90,"REC"
- WRITE ?96
- FOR I=1:1:96
- WRITE @IOBS
- +27 WRITE PRCHULN
- KILL PRCHHSP,PRCHINV,PRCHSHP,PRCHST,S,V,^TMP($JOB,"P")
- SET PRCHL=18
- SET P=1
- SET PRCH=0
- +28 ;
- CNTI SET PRCH=$ORDER(^PRC(442,D0,2,PRCH))
- if PRCH'>0
- GOTO CNTD
- SET LITEM=$GET(^(PRCH,2))
- SET PRCHLB=1
- SET PRCHL1=$PIECE(LITEM,U,4)
- if $PIECE(^(0),U,6)]""
- SET PRCHL1=PRCHL1+1
- if $PIECE(^(0),U,13)]""
- SET PRCHL1=PRCHL1+1
- if $PIECE(LITEM,U,9)]""
- SET PRCHL1=PRCHL1+1
- if $PIECE(LITEM,U,11)]""
- SET PRCHL1=PRCHL1+1
- +1 if $PIECE($GET(^PRC(442,D0,2,PRCH,2)),U,9)]""!($PIECE($GET(^(2)),U,11)]"")
- SET PRCHL1=PRCHL1+3
- if $PIECE($GET(^PRC(442,D0,2,PRCH,4)),U,12)
- SET PRCHL1=PRCHL1+1
- if P=1
- SET PRCHL1=PRCHL1+3
- +2 if PRCHL-1<1
- DO P
- SET ^TMP($JOB,"P",P,PRCH)=PRCHLB_U_PRCHL1
- SET PRCHL=PRCHL-PRCHL1-1
- +3 GOTO CNTI
- CNTD SET (PRCHLE,PRCHLB,PRCH)=0
- FOR J=0:0
- SET PRCH=$ORDER(^PRC(442,D0,3,PRCH))
- if PRCH=""!(PRCH'>0)
- QUIT
- if PRCHLB=0
- SET PRCHLB=PRCH
- SET PRCHLE=PRCH
- if PRCHL-2<1
- DO P1
- SET ^TMP($JOB,"P",P,"D")=PRCHLB_U_PRCHLE
- SET PRCHL=PRCHL-2
- +1 IF $PIECE(PRCH0,U,13)>0!($PIECE(PRCH0,U,18)>0)
- if PRCHL-3<1
- DO P1
- SET ^TMP($JOB,"P",P,"E")=$PIECE(PRCH0,U,13)
- SET PRCHL=PRCHL-3
- IF PRCHDES="R"
- IF PRCHDTA
- IF PRCHFPT=1
- SET PRCHDTA=PRCHDTA+$PIECE(PRCH0,U,13)
- +2 IF $DATA(^PRC(442,D0,15))
- FOR J=0:0
- SET J=$ORDER(^PRC(442,D0,15,J))
- if 'J
- QUIT
- SET PRCHJ=^(J,0)
- SET PRCH="F"_J_U_+PRCHJ
- SET PRCHLB=1
- SET PRCHL1=$PIECE(PRCHJ,U,2)
- if PRCHL-1<PRCHL1
- DO P
- SET ^TMP($JOB,"P",P,PRCH)=PRCHLB_U_PRCHL1
- SET PRCHL=PRCHL-PRCHL1-1
- +3 if '$DATA(^PRC(442,D0,4,0))
- GOTO REQ
- KILL ^UTILITY($JOB,"W")
- SET PRCH="W"
- SET DIWL=1
- SET DIWR=64
- SET DIWF=""
- SET PRCHJ=0
- FOR
- SET PRCHJ=$ORDER(^PRC(442,D0,4,PRCHJ))
- if PRCHJ=""
- QUIT
- SET X=^(PRCHJ,0)
- DO DIWP^PRCUTL($GET(DA))
- +4 KILL ^TMP($JOB,"PRCH")
- SET %X="^UTILITY($J,""W"",DIWL,"
- SET %Y="^TMP($J,""PRCH"",1,"
- DO %XY^%RCR
- +5 SET PRCHL1=+^UTILITY($JOB,"W",DIWL)
- SET PRCHLB=1
- if PRCHL-1<PRCHL1
- DO P
- SET ^TMP($JOB,"P",P,"W")=PRCHLB_U_PRCHL1
- SET PRCHL=PRCHL-PRCHL1-1
- +6 ;
- REQ IF $DATA(^PRC(442,D0,13,0))
- SET (PRCHLE,PRCHLB,PRCH)=0
- FOR J=0:0
- SET PRCH=$ORDER(^PRC(442,D0,13,PRCH))
- if 'PRCH
- QUIT
- if PRCHLB=0
- SET I=3
- SET PRCHLB=PRCH
- SET PRCHLE=PRCH
- if PRCHL-I<3
- DO P1
- SET ^TMP($JOB,"P",P,"X")=PRCHLB_U_PRCHLE
- SET PRCHL=PRCHL-I
- SET I=2
- +1 ;
- BOCLN SET CHGSHP=$PIECE($GET(^PRC(442,D0,0)),U,13)
- +1 SET (N,COUNT)=0
- IF $GET(^PRC(442,D0,22,0))'=""
- FOR
- SET COUNT=$ORDER(^PRC(442,D0,22,COUNT))
- if COUNT=""!(COUNT'>0)
- QUIT
- SET BCT=$GET(^(COUNT,0))
- IF $PIECE(BCT,U,3)'=991
- SET N=N+1
- +2 if CHGSHP>0
- SET N=N+1
- +3 SET N=N-2
- if N<1
- SET N=0
- +4 SET BOCPG=N\45
- SET BOCPG=$SELECT(N#45'=0:BOCPG+1,1:BOCPG)
- if PRCHL-1<3
- SET PRCHL=45
- SET P=P+BOCPG
- +5 GOTO ^PRCHFPT2
- +6 ;
- P SET PRCHL=45
- SET P=P+1
- QUIT
- +1 ;
- P1 SET PRCHLB=PRCHLE
- SET PRCHL=45
- SET P=P+1
- QUIT
- +1 ;
- DT IF Y
- WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
- QUIT
- +1 QUIT
- +2 ;
- TY SET X=+$PIECE(PRCH1,U,7)
- SET X=$PIECE($GET(^PRCD(420.8,X,0)),U,1)
- SET X=$SELECT(X=2:"PURCHASE ORDER",X="B":"DELIVERY & PURCHASE ORDER",X="":"",1:"DELIVERY ORDER")
- +1 QUIT
- +2 ;
- INV ;
- +1 IF $PIECE($GET(^PRC(442,D0,0)),U,2)=25
- Begin DoDot:1
- +2 NEW PRCA,PRCB,PRCC
- +3 SET PRCHINV(1)="** No Purchase Card Info"
- SET PRCHINV(2)=""
- SET PRCHINV(3)=""
- SET PRCHINV(4)=""
- +4 SET PRCA=$PIECE($GET(^PRC(442,D0,23)),U,8)
- if PRCA'>0
- QUIT
- +5 SET PRCB=$GET(^PRC(440.5,PRCA,0))
- if PRCB=""
- QUIT
- +6 SET PRCC=$PIECE(PRCB,U,8)
- if PRCC>0
- SET PRCC=$PIECE($GET(^VA(200,PRCC,0)),U)
- +7 SET PRCA=$PIECE(PRCB,U,11)
- SET PRCHINV(1)="PURCHASE CARD HOLDER"
- +8 SET PRCHINV(2)=" "_$EXTRACT(PRCC,1,25)
- SET PRCHINV(3)="PURCHASE CARD NAME"
- +9 SET PRCHINV(4)=" "_$EXTRACT(PRCA,1,25)
- End DoDot:1
- QUIT
- +10 SET PRCHINV(1)=" MAIL INVOICE TO:"
- SET PRCHINV(2)=" "_$PIECE(PRCHINV,U,1)
- SET PRCHINV(3)=" "_$PIECE(PRCHINV,U,2)
- SET X=4
- +11 if $PIECE(PRCHINV,U,3)]""
- SET PRCHINV(X)=" "_$PIECE(PRCHINV,U,3)
- SET X=X+1
- if $PIECE(PRCHINV,U,4)]""
- SET PRCHINV(X)=" "_$PIECE(PRCHINV,U,4)
- SET X=X+1
- +12 SET PRCHINV(X)=" "_$PIECE(PRCHINV,U,5)_", "_$PIECE($GET(^DIC(5,+$PIECE(PRCHINV,U,6),0)),U,2)_" "_$PIECE(PRCHINV,U,7)
- +13 QUIT
