Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACRFSSD

ACRFSSD.m

Go to the documentation of this file. 
  1. ACRFSSD ;IHS/OIRM/DSD/THL,AEF - DISPLAY SERVICES/SUPPLIES; [ 11/01/2001   9:44 AM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
  1.  ;;ROUTINE TO DISPALY SERVICES/SUPPLIES
  1. DISP ;EP;TO DISPLAY SUPPLIES/SERVICE
  1.  Q:$D(ACROUT)
  1.  K ACRQUIT
  1.  N ACRX
  1.  D SSCHK^ACRFSSA
  1.  I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
  1.  I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
  1.  N ACRLBDA,ACRCANDA,ACROBJDA,ACRSSADA,ACRALWDA,ACRDA,ACRFY,ACRI
  1.  S ACRJ=ACRJ+1
  1. DISP1 S X=^ACRSS(ACRSSDA,0)
  1.  S ACRSS=ACRSSDA_U_X
  1.  S ACRSS3(ACRJ)=$G(^ACRSS(ACRSSDA,"NMS"))
  1.  S ACRSS1=^ACRSS(ACRSSDA,"DT")
  1.  S ACRITEM=+X
  1.  S ACRVENDA=$P($G(^ACRSS(ACRSSDA,"VND")),U)
  1.  S ACRSS2=$G(^ACRSS(ACRSSDA,"DESC"))
  1.  S ACRSS4=$G(^ACRSS(ACRSSDA,"NOTES"))
  1.  S ACRSS(ACRJ)=ACRSS
  1.  S ACRSSITM=$S($P(ACRSS3(ACRJ),U)]"":$P(ACRSS3(ACRJ),U),$P(ACRSS3(ACRJ),U,2)]"":$P(ACRSS3(ACRJ),U,2),1:"")
  1.  S ACRSSITM=$E(ACRSSITM,1,30)
  1.  S ACROBJDA=$P(ACRSS,U,5)
  1.  S ACRSSUP=$P(ACRSS1,U,3)
  1.  S ACRSSQA=$P(ACRSS1,U,5)
  1.  S ACRSSDS1=$E($P(ACRSS2,U),1,30)
  1.  S ACRSSDS2=$E($P(ACRSS2,U,2),1,30)
  1.  S ACRSSNT1=$P(ACRSS4,U)
  1.  S ACRSSNT2=$P(ACRSS4,U,2)
  1.  S ACRSSNT3=$P(ACRSS4,U,3)
  1.  S ACRSSNT4=$P(ACRSS4,U,4)
  1.  S ACRSSNT5=$P(ACRSS4,U,5)
  1.  S ACRSSIT=$P(ACRSS1,U,4)
  1.  S ACRSSDS3=$P(ACRSS2,U,3)
  1.  S ACRSSDS4=$P(ACRSS2,U,4)
  1.  S ACRSSDS5=$P(ACRSS2,U,5)
  1.  S ACRSSORD=$P(ACRSS1,U)
  1.  S ACRSSUNT=$P(ACRSS1,U,2)
  1.  S ACRSSUNT=$S($D(^ACRUI(+ACRSSUNT,0)):$P(^(0),U),1:"**")
  1.  S ACRSSCAN=$P(ACRSS,U,6)
  1.  S ACRVENAM=""
  1.  S ACRSSACP=$P(ACRSS1,U,6)
  1.  I ACRVENDA,$D(^AUTTVNDR(ACRVENDA,0)) S ACRVENAM=$P(^(0),U)
  1.  S ACROBJ=$S(ACROBJDA]"":$P(^AUTTOBJC(ACROBJDA,0),U),1:"")
  1.  S:'$D(ACRVENO) ACRVENO=ACRVENDA
  1.  S ACRCAN=$S(ACRSSCAN]"":$P(^AUTTCAN(ACRSSCAN,0),U),1:"")
  1.  I ACRITEM'=ACRJ,ACRITEM'=999 D
  1.  .S $P(^ACRSS(ACRSSDA,0),U)=ACRJ
  1.  .S ACRITEM=ACRJ
  1.  D P
  1.  Q:$D(ACRQUIT)
  1.  W !,ACRITEM
  1.  I $P(ACRSS3(ACRJ),U)]"" D
  1.  .W:'$D(ACRORIGF) ?3,"|"
  1.  .W ?4,"VON: ",$P(ACRSS3(ACRJ),U)
  1.  .D W
  1.  .D P
  1.  .W !
  1.  I $P(ACRSS3(ACRJ),U,3)]"" D
  1.  .W:'$D(ACRORIGF) ?3,"|"
  1.  .W ?4,"NDC: ",$P(ACRSS3(ACRJ),U,3)
  1.  .D W
  1.  .D P
  1.  .W !
  1.  I $P(ACRSS3(ACRJ),U,2)]"" D
  1.  .W:'$D(ACRORIGF) ?3,"|"
  1.  .W ?4,"NSN: ",$P(ACRSS3(ACRJ),U,2)
  1.  .D W
  1.  .D P
  1.  .W !
  1.  W:'$D(ACRORIGF) ?3,"|"
  1.  W ?4,ACRSSDS1
  1.  I +ACRSSUP]"" D
  1.  .S X="O"
  1.  .D W1
  1.  .W ACRSSORD
  1.  .S X="U"
  1.  .D W1
  1.  .W ACRSSUNT
  1.  .S X="C"
  1.  .D W1
  1.  .W:'$D(ACRPQT) $J($FN(ACRSSUP,"P",$S($L($P(ACRSSUP,".",2))>2:$L($P(ACRSSUP,".",2)),1:2)),10)
  1.  .S X="T"
  1.  .D W1
  1.  .W:'$D(ACRPQT) $J($FN(ACRSSIT,"P",2),11)
  1.  .S X="F"
  1.  .D W1
  1.  I ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326)&'$D(ACRPRT)&'$D(ACRPQT) D
  1.  .W ?68,ACROBJ
  1.  .W ?72,"|"
  1.  .W ?73,ACRCAN
  1.  D P
  1.  Q:$D(ACRQUIT)
  1.  F ACRSSD=2:1:5 I @("ACRSSDS"_ACRSSD)]"" D
  1.  .W !?3
  1.  .W:'$D(ACRORIGF) "|"
  1.  .W ?4,@("ACRSSDS"_ACRSSD)
  1.  .D W
  1.  .D P
  1.  D SSNOTES^ACRFSSD1
  1.  D ADDM^ACRFSSD1
  1.  W:$P(^ACRSS(ACRSSDA,"DT"),U,10)="8" !?6,"(3.5 % VA SURCHARGE ADDED TO THIS ITEM.)"
  1.  D EQUIP:$E(ACROBJ,1,2)=31&(ACROBJ'="319Y")&(ACRREFX=116)&(+^ACRSS(ACRSSDA,0)'=999)
  1.  D REPAIR:"^257A^257E^257J^2576^"[(U_ACROBJ_U)&(ACRREFX=116)
  1.  K ACRSSNT1,ACRSSNT2,ACRSSNT3,ACRSSNT4,ACRSSNT5,ACRSSDS1,ACRSSDS2,ACRSSDS3,ACRSSDS4,ACRSSDS5,ACRSSD
  1.  Q
  1. P ;EP;FOR PAGE CONTROL OF REQUISITION/PO ITEMS
  1.  ;;CALLED FROM PRINT TEMPLATES.  DO NOT DELETE OR MOVE
  1.  Q:$D(ACRQUIT)
  1.  S:$D(D0) ACRD0=D0
  1.  S ACRPHEAD=$S(ACRREFX=103:4,ACRREFX=349!(ACRREFX=326):20,1:10)
  1.  S:$D(ACRORIGF)&(+$G(ACRPSC)=347!(+$G(ACRPSC)=326)) ACRPHEAD=10
  1.  I IOSL-$S($E(IOST,1,2)="C-":10,1:ACRPHEAD)<$Y!($D(ACRORIGF)&($Y>$P($G(ACRPSC),U,2))) D
  1.  .S ACRPHEAD=$S($E(IOST,1,2)="C-":5,1:ACRPHEAD)
  1.  .I $E(IOST,1,2)="C-" D
  1.  ..S DIR(0)="YO"
  1.  ..S DIR("A")="Display Remaining Items"
  1.  ..S DIR("B")="YES"
  1.  ..W !
  1.  ..D DIR^ACRFDIC
  1.  ..S:Y'=1 ACRQUIT=""
  1.  .K ACROUT
  1.  .I $D(ACRORIGF) D
  1.  ..N X
  1.  ..S X="DISP^ACRF"_+ACRPSC
  1.  ..S ACRTOP=""
  1.  ..D @X
  1.  ..K ACRORIGF
  1.  .I '$D(ACRQUIT),'$D(ACRORIGF) D
  1.  ..D PHEAD^ACRFSS12
  1.  ..D HEAD^ACRFSSD1
  1.  S:$D(ACRD0) D0=ACRD0
  1.  K ACRD0
  1.  Q
  1. W ;EP;LINES FOR DOCUMENT FORMATTING
  1.  Q:$D(ACRORIGF)
  1.  W:$X<34 ?34,"|"
  1.  W:$X<41 ?41,"|"
  1.  W:$X<44 ?44,"|"
  1.  W:$X<55 ?55,"|"
  1.  W:$X<67 ?67,"|"
  1.  I ACRREFX'=103,ACRREFX'=349,ACRREFX'=326,'$D(ACRPRT),$X<72 W ?72,"|"
  1.  Q
  1. W1 ;EP;LINES FOR DOCUMENT FORMATTING
  1.  I $D(ACRORIGF) D @("W"_+ACRPSC_X) Q
  1.  D @("W1"_X)
  1.  Q
  1.  I $X<3!($X>75) W !?3,"|"
  1.  Q
  1. W1O I $X<35 W ?34,"|"
  1.  Q
  1. W1U I $X<42 W ?41,"|"
  1.  Q
  1. W1C I $X<45 W ?44,"|"
  1.  Q
  1. W1T I $X<56 W ?55,"|"
  1.  Q
  1. W1F I $X<68 W ?67,"|"
  1.  Q
  1.  I ACRREFX'=103,ACRREFX'=349,ACRREFX'=326,'$D(ACRPRT),$X<72 W ?72,"|"
  1.  Q
  1. W26 I $X<3 W !?2
  1.  Q
  1. W26O I $X<41 W ?41
  1.  Q
  1. W26U I $X<53 W ?53
  1.  Q
  1. W26C I $X<59 W ?59
  1.  Q
  1. W26T I $X<69 W ?69
  1.  Q
  1. W26F I $X<69 W ?69
  1.  Q
  1. W1449 I $X<3 W !?2
  1.  Q
  1. W1449O I $X<45 W ?44
  1.  Q
  1. W1449U I $X<52 W ?51
  1.  Q
  1. W1449C I $X<56 W ?56
  1.  Q
  1. W1449T I $X<67 W ?67
  1.  Q
  1. W1449F I $X<67 W ?67
  1.  Q
  1. W347 I $X<5 W !?5
  1.  Q
  1. W347O I $X<47 W ?47
  1.  Q
  1. W347U I $X<53 W ?53
  1.  Q
  1. W347C I $X<56 W ?56
  1.  Q
  1. W347T I $X<64 W ?64
  1.  Q
  1. W347F I $X<64 W ?64
  1.  Q
  1. W326 I $X<5 W !?5
  1.  Q
  1. W326O I $X<47 W ?47
  1.  Q
  1. W326U I $X<53 W ?53
  1.  Q
  1. W326C I $X<56 W ?56
  1.  Q
  1. W326T I $X<64 W ?64
  1.  Q
  1. W326F I $X<64 W ?64
  1.  Q
  1. W33 I $X<5 W !?5
  1.  Q
  1. W33O I $X<47 W ?47
  1.  Q
  1. W33U I $X<53 W ?53
  1.  Q
  1. W33C I $X<56 W ?56
  1.  Q
  1. W33T I $X<64 W ?64
  1.  Q
  1. W33F I $X<64 W ?64
  1.  Q
  1. EQUIP N DXS,DIP,DC,D0,DN
  1.  S ACREQUIP=""
  1.  S D0=ACRSSDA
  1.  D ^ACRPEQP
  1.  K ACREQUIP
  1.  Q
  1. REPAIR N DXS,DIP,DC,D0,DN
  1.  S ACREQUIP=""
  1.  S D0=ACRSSDA
  1.  D ^ACRPRQR
  1.  K ACREQUIP
  1.  Q