ACRFSSD ;IHS/OIRM/DSD/THL,AEF - DISPLAY SERVICES/SUPPLIES; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;ROUTINE TO DISPALY SERVICES/SUPPLIES
DISP ;EP;TO DISPLAY SUPPLIES/SERVICE
Q:$D(ACROUT)
K ACRQUIT
N ACRX
D SSCHK^ACRFSSA
I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
N ACRLBDA,ACRCANDA,ACROBJDA,ACRSSADA,ACRALWDA,ACRDA,ACRFY,ACRI
S ACRJ=ACRJ+1
DISP1 S X=^ACRSS(ACRSSDA,0)
S ACRSS=ACRSSDA_U_X
S ACRSS3(ACRJ)=$G(^ACRSS(ACRSSDA,"NMS"))
S ACRSS1=^ACRSS(ACRSSDA,"DT")
S ACRITEM=+X
S ACRVENDA=$P($G(^ACRSS(ACRSSDA,"VND")),U)
S ACRSS2=$G(^ACRSS(ACRSSDA,"DESC"))
S ACRSS4=$G(^ACRSS(ACRSSDA,"NOTES"))
S ACRSS(ACRJ)=ACRSS
S ACRSSITM=$S($P(ACRSS3(ACRJ),U)]"":$P(ACRSS3(ACRJ),U),$P(ACRSS3(ACRJ),U,2)]"":$P(ACRSS3(ACRJ),U,2),1:"")
S ACRSSITM=$E(ACRSSITM,1,30)
S ACROBJDA=$P(ACRSS,U,5)
S ACRSSUP=$P(ACRSS1,U,3)
S ACRSSQA=$P(ACRSS1,U,5)
S ACRSSDS1=$E($P(ACRSS2,U),1,30)
S ACRSSDS2=$E($P(ACRSS2,U,2),1,30)
S ACRSSNT1=$P(ACRSS4,U)
S ACRSSNT2=$P(ACRSS4,U,2)
S ACRSSNT3=$P(ACRSS4,U,3)
S ACRSSNT4=$P(ACRSS4,U,4)
S ACRSSNT5=$P(ACRSS4,U,5)
S ACRSSIT=$P(ACRSS1,U,4)
S ACRSSDS3=$P(ACRSS2,U,3)
S ACRSSDS4=$P(ACRSS2,U,4)
S ACRSSDS5=$P(ACRSS2,U,5)
S ACRSSORD=$P(ACRSS1,U)
S ACRSSUNT=$P(ACRSS1,U,2)
S ACRSSUNT=$S($D(^ACRUI(+ACRSSUNT,0)):$P(^(0),U),1:"**")
S ACRSSCAN=$P(ACRSS,U,6)
S ACRVENAM=""
S ACRSSACP=$P(ACRSS1,U,6)
I ACRVENDA,$D(^AUTTVNDR(ACRVENDA,0)) S ACRVENAM=$P(^(0),U)
S ACROBJ=$S(ACROBJDA]"":$P(^AUTTOBJC(ACROBJDA,0),U),1:"")
S:'$D(ACRVENO) ACRVENO=ACRVENDA
S ACRCAN=$S(ACRSSCAN]"":$P(^AUTTCAN(ACRSSCAN,0),U),1:"")
I ACRITEM'=ACRJ,ACRITEM'=999 D
.S $P(^ACRSS(ACRSSDA,0),U)=ACRJ
.S ACRITEM=ACRJ
D P
Q:$D(ACRQUIT)
W !,ACRITEM
I $P(ACRSS3(ACRJ),U)]"" D
.W:'$D(ACRORIGF) ?3,"|"
.W ?4,"VON: ",$P(ACRSS3(ACRJ),U)
.D W
.D P
.W !
I $P(ACRSS3(ACRJ),U,3)]"" D
.W:'$D(ACRORIGF) ?3,"|"
.W ?4,"NDC: ",$P(ACRSS3(ACRJ),U,3)
.D W
.D P
.W !
I $P(ACRSS3(ACRJ),U,2)]"" D
.W:'$D(ACRORIGF) ?3,"|"
.W ?4,"NSN: ",$P(ACRSS3(ACRJ),U,2)
.D W
.D P
.W !
W:'$D(ACRORIGF) ?3,"|"
W ?4,ACRSSDS1
I +ACRSSUP]"" D
.S X="O"
.D W1
.W ACRSSORD
.S X="U"
.D W1
.W ACRSSUNT
.S X="C"
.D W1
.W:'$D(ACRPQT) $J($FN(ACRSSUP,"P",$S($L($P(ACRSSUP,".",2))>2:$L($P(ACRSSUP,".",2)),1:2)),10)
.S X="T"
.D W1
.W:'$D(ACRPQT) $J($FN(ACRSSIT,"P",2),11)
.S X="F"
.D W1
I ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326)&'$D(ACRPRT)&'$D(ACRPQT) D
.W ?68,ACROBJ
.W ?72,"|"
.W ?73,ACRCAN
D P
Q:$D(ACRQUIT)
F ACRSSD=2:1:5 I @("ACRSSDS"_ACRSSD)]"" D
.W !?3
.W:'$D(ACRORIGF) "|"
.W ?4,@("ACRSSDS"_ACRSSD)
.D W
.D P
D SSNOTES^ACRFSSD1
D ADDM^ACRFSSD1
W:$P(^ACRSS(ACRSSDA,"DT"),U,10)="8" !?6,"(3.5 % VA SURCHARGE ADDED TO THIS ITEM.)"
D EQUIP:$E(ACROBJ,1,2)=31&(ACROBJ'="319Y")&(ACRREFX=116)&(+^ACRSS(ACRSSDA,0)'=999)
D REPAIR:"^257A^257E^257J^2576^"[(U_ACROBJ_U)&(ACRREFX=116)
K ACRSSNT1,ACRSSNT2,ACRSSNT3,ACRSSNT4,ACRSSNT5,ACRSSDS1,ACRSSDS2,ACRSSDS3,ACRSSDS4,ACRSSDS5,ACRSSD
Q
P ;EP;FOR PAGE CONTROL OF REQUISITION/PO ITEMS
;;CALLED FROM PRINT TEMPLATES. DO NOT DELETE OR MOVE
Q:$D(ACRQUIT)
S:$D(D0) ACRD0=D0
S ACRPHEAD=$S(ACRREFX=103:4,ACRREFX=349!(ACRREFX=326):20,1:10)
S:$D(ACRORIGF)&(+$G(ACRPSC)=347!(+$G(ACRPSC)=326)) ACRPHEAD=10
I IOSL-$S($E(IOST,1,2)="C-":10,1:ACRPHEAD)<$Y!($D(ACRORIGF)&($Y>$P($G(ACRPSC),U,2))) D
.S ACRPHEAD=$S($E(IOST,1,2)="C-":5,1:ACRPHEAD)
.I $E(IOST,1,2)="C-" D
..S DIR(0)="YO"
..S DIR("A")="Display Remaining Items"
..S DIR("B")="YES"
..W !
..D DIR^ACRFDIC
..S:Y'=1 ACRQUIT=""
.K ACROUT
.I $D(ACRORIGF) D
..N X
..S X="DISP^ACRF"_+ACRPSC
..S ACRTOP=""
..D @X
..K ACRORIGF
.I '$D(ACRQUIT),'$D(ACRORIGF) D
..D PHEAD^ACRFSS12
..D HEAD^ACRFSSD1
S:$D(ACRD0) D0=ACRD0
K ACRD0
Q
W ;EP;LINES FOR DOCUMENT FORMATTING
Q:$D(ACRORIGF)
W:$X<34 ?34,"|"
W:$X<41 ?41,"|"
W:$X<44 ?44,"|"
W:$X<55 ?55,"|"
W:$X<67 ?67,"|"
I ACRREFX'=103,ACRREFX'=349,ACRREFX'=326,'$D(ACRPRT),$X<72 W ?72,"|"
Q
W1 ;EP;LINES FOR DOCUMENT FORMATTING
I $D(ACRORIGF) D @("W"_+ACRPSC_X) Q
D @("W1"_X)
Q
I $X<3!($X>75) W !?3,"|"
Q
W1O I $X<35 W ?34,"|"
Q
W1U I $X<42 W ?41,"|"
Q
W1C I $X<45 W ?44,"|"
Q
W1T I $X<56 W ?55,"|"
Q
W1F I $X<68 W ?67,"|"
Q
I ACRREFX'=103,ACRREFX'=349,ACRREFX'=326,'$D(ACRPRT),$X<72 W ?72,"|"
Q
W26 I $X<3 W !?2
Q
W26O I $X<41 W ?41
Q
W26U I $X<53 W ?53
Q
W26C I $X<59 W ?59
Q
W26T I $X<69 W ?69
Q
W26F I $X<69 W ?69
Q
W1449 I $X<3 W !?2
Q
W1449O I $X<45 W ?44
Q
W1449U I $X<52 W ?51
Q
W1449C I $X<56 W ?56
Q
W1449T I $X<67 W ?67
Q
W1449F I $X<67 W ?67
Q
W347 I $X<5 W !?5
Q
W347O I $X<47 W ?47
Q
W347U I $X<53 W ?53
Q
W347C I $X<56 W ?56
Q
W347T I $X<64 W ?64
Q
W347F I $X<64 W ?64
Q
W326 I $X<5 W !?5
Q
W326O I $X<47 W ?47
Q
W326U I $X<53 W ?53
Q
W326C I $X<56 W ?56
Q
W326T I $X<64 W ?64
Q
W326F I $X<64 W ?64
Q
W33 I $X<5 W !?5
Q
W33O I $X<47 W ?47
Q
W33U I $X<53 W ?53
Q
W33C I $X<56 W ?56
Q
W33T I $X<64 W ?64
Q
W33F I $X<64 W ?64
Q
EQUIP N DXS,DIP,DC,D0,DN
S ACREQUIP=""
S D0=ACRSSDA
D ^ACRPEQP
K ACREQUIP
Q
REPAIR N DXS,DIP,DC,D0,DN
S ACREQUIP=""
S D0=ACRSSDA
D ^ACRPRQR
K ACREQUIP
Q
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
+2 ;;ROUTINE TO DISPALY SERVICES/SUPPLIES
DISP ;EP;TO DISPLAY SUPPLIES/SERVICE
+1 IF $DATA(ACROUT)
QUIT
+2 KILL ACRQUIT
+3 NEW ACRX
+4 DO SSCHK^ACRFSSA
+5 IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+6 IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+7 NEW ACRLBDA,ACRCANDA,ACROBJDA,ACRSSADA,ACRALWDA,ACRDA,ACRFY,ACRI
+8 SET ACRJ=ACRJ+1
DISP1 SET X=^ACRSS(ACRSSDA,0)
+1 SET ACRSS=ACRSSDA_U_X
+2 SET ACRSS3(ACRJ)=$GET(^ACRSS(ACRSSDA,"NMS"))
+3 SET ACRSS1=^ACRSS(ACRSSDA,"DT")
+4 SET ACRITEM=+X
+5 SET ACRVENDA=$PIECE($GET(^ACRSS(ACRSSDA,"VND")),U)
+6 SET ACRSS2=$GET(^ACRSS(ACRSSDA,"DESC"))
+7 SET ACRSS4=$GET(^ACRSS(ACRSSDA,"NOTES"))
+8 SET ACRSS(ACRJ)=ACRSS
+9 SET ACRSSITM=$SELECT($PIECE(ACRSS3(ACRJ),U)]"":$PIECE(ACRSS3(ACRJ),U),$PIECE(ACRSS3(ACRJ),U,2)]"":$PIECE(ACRSS3(ACRJ),U,2),1:"")
+10 SET ACRSSITM=$EXTRACT(ACRSSITM,1,30)
+11 SET ACROBJDA=$PIECE(ACRSS,U,5)
+12 SET ACRSSUP=$PIECE(ACRSS1,U,3)
+13 SET ACRSSQA=$PIECE(ACRSS1,U,5)
+14 SET ACRSSDS1=$EXTRACT($PIECE(ACRSS2,U),1,30)
+15 SET ACRSSDS2=$EXTRACT($PIECE(ACRSS2,U,2),1,30)
+16 SET ACRSSNT1=$PIECE(ACRSS4,U)
+17 SET ACRSSNT2=$PIECE(ACRSS4,U,2)
+18 SET ACRSSNT3=$PIECE(ACRSS4,U,3)
+19 SET ACRSSNT4=$PIECE(ACRSS4,U,4)
+20 SET ACRSSNT5=$PIECE(ACRSS4,U,5)
+21 SET ACRSSIT=$PIECE(ACRSS1,U,4)
+22 SET ACRSSDS3=$PIECE(ACRSS2,U,3)
+23 SET ACRSSDS4=$PIECE(ACRSS2,U,4)
+24 SET ACRSSDS5=$PIECE(ACRSS2,U,5)
+25 SET ACRSSORD=$PIECE(ACRSS1,U)
+26 SET ACRSSUNT=$PIECE(ACRSS1,U,2)
+27 SET ACRSSUNT=$SELECT($DATA(^ACRUI(+ACRSSUNT,0)):$PIECE(^(0),U),1:"**")
+28 SET ACRSSCAN=$PIECE(ACRSS,U,6)
+29 SET ACRVENAM=""
+30 SET ACRSSACP=$PIECE(ACRSS1,U,6)
+31 IF ACRVENDA
IF $DATA(^AUTTVNDR(ACRVENDA,0))
SET ACRVENAM=$PIECE(^(0),U)
+32 SET ACROBJ=$SELECT(ACROBJDA]"":$PIECE(^AUTTOBJC(ACROBJDA,0),U),1:"")
+33 IF '$DATA(ACRVENO)
SET ACRVENO=ACRVENDA
+34 SET ACRCAN=$SELECT(ACRSSCAN]"":$PIECE(^AUTTCAN(ACRSSCAN,0),U),1:"")
+35 IF ACRITEM'=ACRJ
IF ACRITEM'=999
Begin DoDot:1
+36 SET $PIECE(^ACRSS(ACRSSDA,0),U)=ACRJ
+37 SET ACRITEM=ACRJ
End DoDot:1
+38 DO P
+39 IF $DATA(ACRQUIT)
QUIT
+40 WRITE !,ACRITEM
+41 IF $PIECE(ACRSS3(ACRJ),U)]""
Begin DoDot:1
+42 IF '$DATA(ACRORIGF)
WRITE ?3,"|"
+43 WRITE ?4,"VON: ",$PIECE(ACRSS3(ACRJ),U)
+44 DO W
+45 DO P
+46 WRITE !
End DoDot:1
+47 IF $PIECE(ACRSS3(ACRJ),U,3)]""
Begin DoDot:1
+48 IF '$DATA(ACRORIGF)
WRITE ?3,"|"
+49 WRITE ?4,"NDC: ",$PIECE(ACRSS3(ACRJ),U,3)
+50 DO W
+51 DO P
+52 WRITE !
End DoDot:1
+53 IF $PIECE(ACRSS3(ACRJ),U,2)]""
Begin DoDot:1
+54 IF '$DATA(ACRORIGF)
WRITE ?3,"|"
+55 WRITE ?4,"NSN: ",$PIECE(ACRSS3(ACRJ),U,2)
+56 DO W
+57 DO P
+58 WRITE !
End DoDot:1
+59 IF '$DATA(ACRORIGF)
WRITE ?3,"|"
+60 WRITE ?4,ACRSSDS1
+61 IF +ACRSSUP]""
Begin DoDot:1
+62 SET X="O"
+63 DO W1
+64 WRITE ACRSSORD
+65 SET X="U"
+66 DO W1
+67 WRITE ACRSSUNT
+68 SET X="C"
+69 DO W1
+70 IF '$DATA(ACRPQT)
WRITE $JUSTIFY($FNUMBER(ACRSSUP,"P",$SELECT($LENGTH($PIECE(ACRSSUP,".",2))>2:$LENGTH($PIECE(ACRSSUP,".",2)),1:2)),10)
+71 SET X="T"
+72 DO W1
+73 IF '$DATA(ACRPQT)
WRITE $JUSTIFY($FNUMBER(ACRSSIT,"P",2),11)
+74 SET X="F"
+75 DO W1
End DoDot:1
+76 IF ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326)&'$DATA(ACRPRT)&'$DATA(ACRPQT)
Begin DoDot:1
+77 WRITE ?68,ACROBJ
+78 WRITE ?72,"|"
+79 WRITE ?73,ACRCAN
End DoDot:1
+80 DO P
+81 IF $DATA(ACRQUIT)
QUIT
+82 FOR ACRSSD=2:1:5
IF @("ACRSSDS"_ACRSSD)]""
Begin DoDot:1
+83 WRITE !?3
+84 IF '$DATA(ACRORIGF)
WRITE "|"
+85 WRITE ?4,@("ACRSSDS"_ACRSSD)
+86 DO W
+87 DO P
End DoDot:1
+88 DO SSNOTES^ACRFSSD1
+89 DO ADDM^ACRFSSD1
+90 IF $PIECE(^ACRSS(ACRSSDA,"DT"),U,10)="8"
WRITE !?6,"(3.5 % VA SURCHARGE ADDED TO THIS ITEM.)"
+91 IF $EXTRACT(ACROBJ,1,2)=31&(ACROBJ'="319Y")&(ACRREFX=116)&(+^ACRSS(ACRSSDA,0)'=999)
DO EQUIP
+92 IF "^257A^257E^257J^2576^"[(U_ACROBJ_U)&(ACRREFX=116)
DO REPAIR
+93 KILL ACRSSNT1,ACRSSNT2,ACRSSNT3,ACRSSNT4,ACRSSNT5,ACRSSDS1,ACRSSDS2,ACRSSDS3,ACRSSDS4,ACRSSDS5,ACRSSD
+94 QUIT
P ;EP;FOR PAGE CONTROL OF REQUISITION/PO ITEMS
+1 ;;CALLED FROM PRINT TEMPLATES. DO NOT DELETE OR MOVE
+2 IF $DATA(ACRQUIT)
QUIT
+3 IF $DATA(D0)
SET ACRD0=D0
+4 SET ACRPHEAD=$SELECT(ACRREFX=103:4,ACRREFX=349!(ACRREFX=326):20,1:10)
+5 IF $DATA(ACRORIGF)&(+$GET(ACRPSC)=347!(+$GET(ACRPSC)=326))
SET ACRPHEAD=10
+6 IF IOSL-$SELECT($EXTRACT(IOST,1,2)="C-":10,1:ACRPHEAD)<$Y!($DATA(ACRORIGF)&($Y>$PIECE($GET(ACRPSC),U,2)))
Begin DoDot:1
+7 SET ACRPHEAD=$SELECT($EXTRACT(IOST,1,2)="C-":5,1:ACRPHEAD)
+8 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:2
+9 SET DIR(0)="YO"
+10 SET DIR("A")="Display Remaining Items"
+11 SET DIR("B")="YES"
+12 WRITE !
+13 DO DIR^ACRFDIC
+14 IF Y'=1
SET ACRQUIT=""
End DoDot:2
+15 KILL ACROUT
+16 IF $DATA(ACRORIGF)
Begin DoDot:2
+17 NEW X
+18 SET X="DISP^ACRF"_+ACRPSC
+19 SET ACRTOP=""
+20 DO @X
+21 KILL ACRORIGF
End DoDot:2
+22 IF '$DATA(ACRQUIT)
IF '$DATA(ACRORIGF)
Begin DoDot:2
+23 DO PHEAD^ACRFSS12
+24 DO HEAD^ACRFSSD1
End DoDot:2
End DoDot:1
+25 IF $DATA(ACRD0)
SET D0=ACRD0
+26 KILL ACRD0
+27 QUIT
W ;EP;LINES FOR DOCUMENT FORMATTING
+1 IF $DATA(ACRORIGF)
QUIT
+2 IF $X<34
WRITE ?34,"|"
+3 IF $X<41
WRITE ?41,"|"
+4 IF $X<44
WRITE ?44,"|"
+5 IF $X<55
WRITE ?55,"|"
+6 IF $X<67
WRITE ?67,"|"
+7 IF ACRREFX'=103
IF ACRREFX'=349
IF ACRREFX'=326
IF '$DATA(ACRPRT)
IF $X<72
WRITE ?72,"|"
+8 QUIT
W1 ;EP;LINES FOR DOCUMENT FORMATTING
+1 IF $DATA(ACRORIGF)
DO @("W"_+ACRPSC_X)
QUIT
+2 DO @("W1"_X)
+3 QUIT
+4 IF $X<3!($X>75)
WRITE !?3,"|"
+5 QUIT
W1O IF $X<35
WRITE ?34,"|"
+1 QUIT
W1U IF $X<42
WRITE ?41,"|"
+1 QUIT
W1C IF $X<45
WRITE ?44,"|"
+1 QUIT
W1T IF $X<56
WRITE ?55,"|"
+1 QUIT
W1F IF $X<68
WRITE ?67,"|"
+1 QUIT
+2 IF ACRREFX'=103
IF ACRREFX'=349
IF ACRREFX'=326
IF '$DATA(ACRPRT)
IF $X<72
WRITE ?72,"|"
+3 QUIT
W26 IF $X<3
WRITE !?2
+1 QUIT
W26O IF $X<41
WRITE ?41
+1 QUIT
W26U IF $X<53
WRITE ?53
+1 QUIT
W26C IF $X<59
WRITE ?59
+1 QUIT
W26T IF $X<69
WRITE ?69
+1 QUIT
W26F IF $X<69
WRITE ?69
+1 QUIT
W1449 IF $X<3
WRITE !?2
+1 QUIT
W1449O IF $X<45
WRITE ?44
+1 QUIT
W1449U IF $X<52
WRITE ?51
+1 QUIT
W1449C IF $X<56
WRITE ?56
+1 QUIT
W1449T IF $X<67
WRITE ?67
+1 QUIT
W1449F IF $X<67
WRITE ?67
+1 QUIT
W347 IF $X<5
WRITE !?5
+1 QUIT
W347O IF $X<47
WRITE ?47
+1 QUIT
W347U IF $X<53
WRITE ?53
+1 QUIT
W347C IF $X<56
WRITE ?56
+1 QUIT
W347T IF $X<64
WRITE ?64
+1 QUIT
W347F IF $X<64
WRITE ?64
+1 QUIT
W326 IF $X<5
WRITE !?5
+1 QUIT
W326O IF $X<47
WRITE ?47
+1 QUIT
W326U IF $X<53
WRITE ?53
+1 QUIT
W326C IF $X<56
WRITE ?56
+1 QUIT
W326T IF $X<64
WRITE ?64
+1 QUIT
W326F IF $X<64
WRITE ?64
+1 QUIT
W33 IF $X<5
WRITE !?5
+1 QUIT
W33O IF $X<47
WRITE ?47
+1 QUIT
W33U IF $X<53
WRITE ?53
+1 QUIT
W33C IF $X<56
WRITE ?56
+1 QUIT
W33T IF $X<64
WRITE ?64
+1 QUIT
W33F IF $X<64
WRITE ?64
+1 QUIT
EQUIP NEW DXS,DIP,DC,D0,DN
+1 SET ACREQUIP=""
+2 SET D0=ACRSSDA
+3 DO ^ACRPEQP
+4 KILL ACREQUIP
+5 QUIT
REPAIR NEW DXS,DIP,DC,D0,DN
+1 SET ACREQUIP=""
+2 SET D0=ACRSSDA
+3 DO ^ACRPRQR
+4 KILL ACREQUIP
+5 QUIT
