ACRF3542 ;IHS/OIRM/DSD/THL,AEF - GSA FORM 3542; [ 09/22/2005 4:15 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**14,19**;NOV 05, 2001
;;PRINT GSA FORM 3542
EN S ACR3542=""
D EN1
EXIT K ACR
Q
EN1 D DOC
Q:$D(ACRQUIT)
S (ACRSSDA,ACRSSTOT)=0
F ACRI=1:1 S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA D
.S ACRSSTOT=ACRSSTOT+$P($G(^ACRSS(ACRSSDA,"DT")),U,4)
D HEAD,SS
Q
SS S ACRSSDA=0
F ACRI=1:1 S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA D S1 Q:$D(ACRQUIT)!$D(ACROUT)
W !?48,"|7. ESTIMATED TOTAL|",$J($FN(ACRSSTOT,"P",2),12)
D L
W !,"8. REMARKS:"
W !
D L
D PAUSE^ACRFWARN
I $E(IOST,1,2)="P-",IOSL-20<$Y W @IOF D HEAD
S ACRREFX=103
D ^ACRFPAPV
D ^ACRFPSS
D DISP
Q
S1 D SETSS^ACRFSSA
S ACRNSN=$P(ACRSSNMS,U,2)
S ACRSSDC1=$P(ACRSSDSC,U)
S:ACRNSN="" ACRNSN=ACRSSDC1
S:ACRNSN'?4N1"-"2UN1"-"3N1"-"4N.E ACRNSN="9999-99-999-9999"
S ACRNSN=$TR(ACRNSN,"-","")
S ACRNSN=$E(ACRNSN,7,14)
S ACRSN=$P(ACRSS0,U,14)
F ACRJ=1:1:4-($L(ACRRQD)-1) S ACRRQD="0"_ACRRQD
F ACRJ=1:1:3-($L(ACRSN)-1) S ACRSN="0"_ACRSN
D L4
I IOSL-5<$Y,$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) D Q
.D PAUSE^ACRFWARN
.W @IOF
I $E(IOST,1,2)="P-",IOSL-5<$Y,$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) D
.W @IOF
.D HEAD
Q
DOC D SETDOC^ACRFEA1
DOC1 ;EP;TO SET FEDSTRIP VARIABLES
K ACRFLDA,ACRFINDA
S ACRFS=$G(^ACRDOC(ACRDOCDA,3))
N ACRI
F ACRI=11:1:15 I $P(ACRFS,U,ACRI)="" S ACRQUIT="" Q
S ACRFLDA=$P(ACRFS,U,13)
S ACRRTID=$P(ACRFS,U,11)
S ACRFSID=$P(ACRFS,U,12)
S ACRFINDA=$P(ACRFS,U,14)
S ACRSIG=$P(ACRFS,U,15)
S X=$P(ACRDOCDT,U,4)
S ACRPRIOR=$S(X="E":"03",X="P":"08",1:15)
S X=+$G(^ACRDOC(ACRDOCDA,"PA"))
S ACRRA=$P($G(^ACRDOC(ACRDOCDA,"REQ2")),U,8)
;S X=$S(X:$P(^VA(200,X,0),U),1:"") ;ACR*2.1*19.02 IM16848
S X=$S(X:$$NAME2^ACRFUTL1(X),1:"") ;ACR*2.1*19.02 IM16848
S ACRPURA=$P($P(X,",",2)," ")_" "_$P(X,",")
S ACRLBDA=$P(ACRDOC0,U,6)
S ACRDPTDA=$P(^ACRLOCB(ACRLBDA,0),U,5)
S:'ACRFLDA ACRFLDA=$P(^ACRDEPT(ACRDPTDA,0),U,2)
S ACRFL=$G(^ACRFSCD(+ACRFLDA,0))
S ACRFLRQ=$P(ACRFL,U,2)
S ACRFUND=$P(ACRFL,U,3)
S ACRPODA=$P(^AUTTPRG(ACRDPTDA,0),U,5)
S ACRPOFON=$S(ACRPODA:$P(^ACRPO(ACRPODA,0),U,9),1:"NOT STATED")
I 'ACRFINDA,ACRPODA S ACRFINDA=$P(^ACRPO(ACRPODA,0),U,8)
S ACRFL=$G(^ACRFSCD(+ACRFINDA,0))
S ACRFINRQ=$P(ACRFL,U,2)
S ACRRDATE=$P(ACRDOCPO,U,12)
I ACRRDATE D
.S X=$E(DT,1,3)_"0101"
.D H^%DTC
.S ACRFY=%H,X=ACRRDATE
.D H^%DTC
.S X=%H+1-ACRFY
.S X=$S($L(X)=1:"00"_X,$L(X)=2:"0"_X,1:X)
.S ACRRDATE=X
S X1=$P(ACRDOC0,U,3)+1
S X2=$E($P(ACRDOC0,U,3),1,3)_"0101"
D ^%DTC
S ACRJDATE=$P(ACRDOC0,U,26)
Q
L W $$DASH^ACRFMENU
Q
L4 W !,ACRI
W ?3,"|",ACRNSN
W ?11,"|",$E(ACRSSDC1,1,28)
W ?42,"|",ACRUI
W ?48,"|",ACRRQD
W ?54,"|",$J($FN(ACRUC,"P",2),12)
W ?67,"|",$J($FN(ACRRQD*ACRUC,"P",2),12)
L3 W !,"---|-------|------------------------------|-----|-----|------------|------------"
Q
DISP ;TO DISPLAY CUSTOMER ADDRESS
N DXS,DIP
W !,"10a. "
I $G(ACRRA) D
.;S X=$P($G(^VA(200,ACRRA,0)),U) ;ACR*2.1*19.02 IM16848
.S X=$$NAME2^ACRFUTL1(ACRRA) ;ACR*2.1*19.02 IM16848
.S X=$P($P(X,",",2)," ")_" "_$P(X,",")
.W X
.W ?45,"10b. PHONE: ",$P(^ACRDOC(ACRDOCDA,"REQ"),U,8)
W !,"11 CUSTOMER ADDRESS"
D COMADD
W !,"12. ACTIVITY ADDRESS CODE"
W !?5,ACRFLRQ
W !,"13. AGENCY ACCESS CODE"
W !?5
W:$P($G(^ACRDOC(ACRDOCDA,18)),U,2)]"" $P(^(18),U,2)
D PAUSE^ACRFWARN
Q
HEAD ;PRINT FORM HEADER
W @IOF
D L
W !
I $E($G(IOST),1,2)="C-" W "ARMS REF: ",$P(^ACRDOC(ACRDOCDA,0),U,6),"/",ACRDOCDA
W ?20,"CUSTOMER SUPPLY CENTER ORDER"
W ?60,"DATE: "
S Y=DT
X ^DD("DD")
W Y
D L
W !,"If limited quantities are used, local reproduction is authorized. Otherwise"
W !,"obtain supplies from the National Forms and Publications Center."
D L
W !,"FOR CSC USE ONLY"
W !
W:$P($G(^ACRDOC(ACRDOCDA,18)),U)]"" "CSC TICKET NUMBER: ",$P(^(18),U)
D L
W !,"DOCUMENT #: ",$P(^ACRDOC(ACRDOCDA,0),U)," (",$P(^(0),U,2),")"
F I=42,48,54,67 W ?I,"|" ;ACR*2.1*14.01 IM12272
W !?4,"DHHS #: ",$$EXPDN^ACRFUTL(ACRDOCDA) ;ACR*2.1*14.01 IM12272
W ?42,"| UNIT"
W ?48,"| 4."
W ?54,"| 5."
W ?67,"|6. EXTENDED"
W !,"------------------------------------------| OF"
W ?48,"| QUAN"
W ?54,"| UNIT"
W ?67,"| PRICE"
W !,"1. ITEM #"
W ?11,"| 2. ITEM DESCRIPTION"
W ?42,"|ISSUE"
W ?48,"| TITY"
W ?54,"| PRICE "
W ?67,"| ESTIMATED"
D L
Q
COMADD ;EP;TO PRINT CUSTOMER ADDRESS AND SHIP TO ADDRESS
N ACRST
S ACRST=+$G(^ACRDOC(ACRDOCDA,"POST"))
I ACRST=ACRDPTDA D Q
.S D0=ACRDPTDA
.D ^ACRPDA
W !?3,"ORDERED BY: ",$P(^AUTTPRG(ACRDPTDA,0),U)
W !?3,"SHIP TO...:"
S D0=ACRST
D ^ACRPDA
Q
ACRF3542 ;IHS/OIRM/DSD/THL,AEF - GSA FORM 3542; [ 09/22/2005 4:15 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**14,19**;NOV 05, 2001
+2 ;;PRINT GSA FORM 3542
EN SET ACR3542=""
+1 DO EN1
EXIT KILL ACR
+1 QUIT
EN1 DO DOC
+1 IF $DATA(ACRQUIT)
QUIT
+2 SET (ACRSSDA,ACRSSTOT)=0
+3 FOR ACRI=1:1
SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
IF 'ACRSSDA
QUIT
Begin DoDot:1
+4 SET ACRSSTOT=ACRSSTOT+$PIECE($GET(^ACRSS(ACRSSDA,"DT")),U,4)
End DoDot:1
+5 DO HEAD
DO SS
+6 QUIT
SS SET ACRSSDA=0
+1 FOR ACRI=1:1
SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
IF 'ACRSSDA
QUIT
DO S1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+2 WRITE !?48,"|7. ESTIMATED TOTAL|",$JUSTIFY($FNUMBER(ACRSSTOT,"P",2),12)
+3 DO L
+4 WRITE !,"8. REMARKS:"
+5 WRITE !
+6 DO L
+7 DO PAUSE^ACRFWARN
+8 IF $EXTRACT(IOST,1,2)="P-"
IF IOSL-20<$Y
WRITE @IOF
DO HEAD
+9 SET ACRREFX=103
+10 DO ^ACRFPAPV
+11 DO ^ACRFPSS
+12 DO DISP
+13 QUIT
S1 DO SETSS^ACRFSSA
+1 SET ACRNSN=$PIECE(ACRSSNMS,U,2)
+2 SET ACRSSDC1=$PIECE(ACRSSDSC,U)
+3 IF ACRNSN=""
SET ACRNSN=ACRSSDC1
+4 IF ACRNSN'?4N1"-"2UN1"-"3N1"-"4N.E
SET ACRNSN="9999-99-999-9999"
+5 SET ACRNSN=$TRANSLATE(ACRNSN,"-","")
+6 SET ACRNSN=$EXTRACT(ACRNSN,7,14)
+7 SET ACRSN=$PIECE(ACRSS0,U,14)
+8 FOR ACRJ=1:1:4-($LENGTH(ACRRQD)-1)
SET ACRRQD="0"_ACRRQD
+9 FOR ACRJ=1:1:3-($LENGTH(ACRSN)-1)
SET ACRSN="0"_ACRSN
+10 DO L4
+11 IF IOSL-5<$Y
IF $ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
Begin DoDot:1
+12 DO PAUSE^ACRFWARN
+13 WRITE @IOF
End DoDot:1
QUIT
+14 IF $EXTRACT(IOST,1,2)="P-"
IF IOSL-5<$Y
IF $ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
Begin DoDot:1
+15 WRITE @IOF
+16 DO HEAD
End DoDot:1
+17 QUIT
DOC DO SETDOC^ACRFEA1
DOC1 ;EP;TO SET FEDSTRIP VARIABLES
+1 KILL ACRFLDA,ACRFINDA
+2 SET ACRFS=$GET(^ACRDOC(ACRDOCDA,3))
+3 NEW ACRI
+4 FOR ACRI=11:1:15
IF $PIECE(ACRFS,U,ACRI)=""
SET ACRQUIT=""
QUIT
+5 SET ACRFLDA=$PIECE(ACRFS,U,13)
+6 SET ACRRTID=$PIECE(ACRFS,U,11)
+7 SET ACRFSID=$PIECE(ACRFS,U,12)
+8 SET ACRFINDA=$PIECE(ACRFS,U,14)
+9 SET ACRSIG=$PIECE(ACRFS,U,15)
+10 SET X=$PIECE(ACRDOCDT,U,4)
+11 SET ACRPRIOR=$SELECT(X="E":"03",X="P":"08",1:15)
+12 SET X=+$GET(^ACRDOC(ACRDOCDA,"PA"))
+13 SET ACRRA=$PIECE($GET(^ACRDOC(ACRDOCDA,"REQ2")),U,8)
+14 ;S X=$S(X:$P(^VA(200,X,0),U),1:"") ;ACR*2.1*19.02 IM16848
+15 ;ACR*2.1*19.02 IM16848
SET X=$SELECT(X:$$NAME2^ACRFUTL1(X),1:"")
+16 SET ACRPURA=$PIECE($PIECE(X,",",2)," ")_" "_$PIECE(X,",")
+17 SET ACRLBDA=$PIECE(ACRDOC0,U,6)
+18 SET ACRDPTDA=$PIECE(^ACRLOCB(ACRLBDA,0),U,5)
+19 IF 'ACRFLDA
SET ACRFLDA=$PIECE(^ACRDEPT(ACRDPTDA,0),U,2)
+20 SET ACRFL=$GET(^ACRFSCD(+ACRFLDA,0))
+21 SET ACRFLRQ=$PIECE(ACRFL,U,2)
+22 SET ACRFUND=$PIECE(ACRFL,U,3)
+23 SET ACRPODA=$PIECE(^AUTTPRG(ACRDPTDA,0),U,5)
+24 SET ACRPOFON=$SELECT(ACRPODA:$PIECE(^ACRPO(ACRPODA,0),U,9),1:"NOT STATED")
+25 IF 'ACRFINDA
IF ACRPODA
SET ACRFINDA=$PIECE(^ACRPO(ACRPODA,0),U,8)
+26 SET ACRFL=$GET(^ACRFSCD(+ACRFINDA,0))
+27 SET ACRFINRQ=$PIECE(ACRFL,U,2)
+28 SET ACRRDATE=$PIECE(ACRDOCPO,U,12)
+29 IF ACRRDATE
Begin DoDot:1
+30 SET X=$EXTRACT(DT,1,3)_"0101"
+31 DO H^%DTC
+32 SET ACRFY=%H
SET X=ACRRDATE
+33 DO H^%DTC
+34 SET X=%H+1-ACRFY
+35 SET X=$SELECT($LENGTH(X)=1:"00"_X,$LENGTH(X)=2:"0"_X,1:X)
+36 SET ACRRDATE=X
End DoDot:1
+37 SET X1=$PIECE(ACRDOC0,U,3)+1
+38 SET X2=$EXTRACT($PIECE(ACRDOC0,U,3),1,3)_"0101"
+39 DO ^%DTC
+40 SET ACRJDATE=$PIECE(ACRDOC0,U,26)
+41 QUIT
L WRITE $$DASH^ACRFMENU
+1 QUIT
L4 WRITE !,ACRI
+1 WRITE ?3,"|",ACRNSN
+2 WRITE ?11,"|",$EXTRACT(ACRSSDC1,1,28)
+3 WRITE ?42,"|",ACRUI
+4 WRITE ?48,"|",ACRRQD
+5 WRITE ?54,"|",$JUSTIFY($FNUMBER(ACRUC,"P",2),12)
+6 WRITE ?67,"|",$JUSTIFY($FNUMBER(ACRRQD*ACRUC,"P",2),12)
L3 WRITE !,"---|-------|------------------------------|-----|-----|------------|------------"
+1 QUIT
DISP ;TO DISPLAY CUSTOMER ADDRESS
+1 NEW DXS,DIP
+2 WRITE !,"10a. "
+3 IF $GET(ACRRA)
Begin DoDot:1
+4 ;S X=$P($G(^VA(200,ACRRA,0)),U) ;ACR*2.1*19.02 IM16848
+5 ;ACR*2.1*19.02 IM16848
SET X=$$NAME2^ACRFUTL1(ACRRA)
+6 SET X=$PIECE($PIECE(X,",",2)," ")_" "_$PIECE(X,",")
+7 WRITE X
+8 WRITE ?45,"10b. PHONE: ",$PIECE(^ACRDOC(ACRDOCDA,"REQ"),U,8)
End DoDot:1
+9 WRITE !,"11 CUSTOMER ADDRESS"
+10 DO COMADD
+11 WRITE !,"12. ACTIVITY ADDRESS CODE"
+12 WRITE !?5,ACRFLRQ
+13 WRITE !,"13. AGENCY ACCESS CODE"
+14 WRITE !?5
+15 IF $PIECE($GET(^ACRDOC(ACRDOCDA,18)),U,2)]""
WRITE $PIECE(^(18),U,2)
+16 DO PAUSE^ACRFWARN
+17 QUIT
HEAD ;PRINT FORM HEADER
+1 WRITE @IOF
+2 DO L
+3 WRITE !
+4 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE "ARMS REF: ",$PIECE(^ACRDOC(ACRDOCDA,0),U,6),"/",ACRDOCDA
+5 WRITE ?20,"CUSTOMER SUPPLY CENTER ORDER"
+6 WRITE ?60,"DATE: "
+7 SET Y=DT
+8 XECUTE ^DD("DD")
+9 WRITE Y
+10 DO L
+11 WRITE !,"If limited quantities are used, local reproduction is authorized. Otherwise"
+12 WRITE !,"obtain supplies from the National Forms and Publications Center."
+13 DO L
+14 WRITE !,"FOR CSC USE ONLY"
+15 WRITE !
+16 IF $PIECE($GET(^ACRDOC(ACRDOCDA,18)),U)]""
WRITE "CSC TICKET NUMBER: ",$PIECE(^(18),U)
+17 DO L
+18 WRITE !,"DOCUMENT #: ",$PIECE(^ACRDOC(ACRDOCDA,0),U)," (",$PIECE(^(0),U,2),")"
+19 ;ACR*2.1*14.01 IM12272
FOR I=42,48,54,67
WRITE ?I,"|"
+20 ;ACR*2.1*14.01 IM12272
WRITE !?4,"DHHS #: ",$$EXPDN^ACRFUTL(ACRDOCDA)
+21 WRITE ?42,"| UNIT"
+22 WRITE ?48,"| 4."
+23 WRITE ?54,"| 5."
+24 WRITE ?67,"|6. EXTENDED"
+25 WRITE !,"------------------------------------------| OF"
+26 WRITE ?48,"| QUAN"
+27 WRITE ?54,"| UNIT"
+28 WRITE ?67,"| PRICE"
+29 WRITE !,"1. ITEM #"
+30 WRITE ?11,"| 2. ITEM DESCRIPTION"
+31 WRITE ?42,"|ISSUE"
+32 WRITE ?48,"| TITY"
+33 WRITE ?54,"| PRICE "
+34 WRITE ?67,"| ESTIMATED"
+35 DO L
+36 QUIT
COMADD ;EP;TO PRINT CUSTOMER ADDRESS AND SHIP TO ADDRESS
+1 NEW ACRST
+2 SET ACRST=+$GET(^ACRDOC(ACRDOCDA,"POST"))
+3 IF ACRST=ACRDPTDA
Begin DoDot:1
+4 SET D0=ACRDPTDA
+5 DO ^ACRPDA
End DoDot:1
QUIT
+6 WRITE !?3,"ORDERED BY: ",$PIECE(^AUTTPRG(ACRDPTDA,0),U)
+7 WRITE !?3,"SHIP TO...:"
+8 SET D0=ACRST
+9 DO ^ACRPDA
+10 QUIT
