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

ACRF3542.m

Go to the documentation of this file. 
  1. 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
  1.  ;;PRINT GSA FORM 3542
  1. EN S ACR3542=""
  1.  D EN1
  1. EXIT K ACR
  1.  Q
  1. EN1 D DOC
  1.  Q:$D(ACRQUIT)
  1.  S (ACRSSDA,ACRSSTOT)=0
  1.  F ACRI=1:1 S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA  D
  1.  .S ACRSSTOT=ACRSSTOT+$P($G(^ACRSS(ACRSSDA,"DT")),U,4)
  1.  D HEAD,SS
  1.  Q
  1. SS S ACRSSDA=0
  1.  F ACRI=1:1 S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA  D S1 Q:$D(ACRQUIT)!$D(ACROUT)
  1.  W !?48,"|7. ESTIMATED TOTAL|",$J($FN(ACRSSTOT,"P",2),12)
  1.  D L
  1.  W !,"8. REMARKS:"
  1.  W !
  1.  D L
  1.  D PAUSE^ACRFWARN
  1.  I $E(IOST,1,2)="P-",IOSL-20<$Y W @IOF D HEAD
  1.  S ACRREFX=103
  1.  D ^ACRFPAPV
  1.  D ^ACRFPSS
  1.  D DISP
  1.  Q
  1. S1 D SETSS^ACRFSSA
  1.  S ACRNSN=$P(ACRSSNMS,U,2)
  1.  S ACRSSDC1=$P(ACRSSDSC,U)
  1.  S:ACRNSN="" ACRNSN=ACRSSDC1
  1.  S:ACRNSN'?4N1"-"2UN1"-"3N1"-"4N.E ACRNSN="9999-99-999-9999"
  1.  S ACRNSN=$TR(ACRNSN,"-","")
  1.  S ACRNSN=$E(ACRNSN,7,14)
  1.  S ACRSN=$P(ACRSS0,U,14)
  1.  F ACRJ=1:1:4-($L(ACRRQD)-1) S ACRRQD="0"_ACRRQD
  1.  F ACRJ=1:1:3-($L(ACRSN)-1) S ACRSN="0"_ACRSN
  1.  D L4
  1.  I IOSL-5<$Y,$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) D  Q
  1.  .D PAUSE^ACRFWARN
  1.  .W @IOF
  1.  I $E(IOST,1,2)="P-",IOSL-5<$Y,$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) D
  1.  .W @IOF
  1.  .D HEAD
  1.  Q
  1. DOC D SETDOC^ACRFEA1
  1. DOC1 ;EP;TO SET FEDSTRIP VARIABLES
  1.  K ACRFLDA,ACRFINDA
  1.  S ACRFS=$G(^ACRDOC(ACRDOCDA,3))
  1.  N ACRI
  1.  F ACRI=11:1:15 I $P(ACRFS,U,ACRI)="" S ACRQUIT="" Q
  1.  S ACRFLDA=$P(ACRFS,U,13)
  1.  S ACRRTID=$P(ACRFS,U,11)
  1.  S ACRFSID=$P(ACRFS,U,12)
  1.  S ACRFINDA=$P(ACRFS,U,14)
  1.  S ACRSIG=$P(ACRFS,U,15)
  1.  S X=$P(ACRDOCDT,U,4)
  1.  S ACRPRIOR=$S(X="E":"03",X="P":"08",1:15)
  1.  S X=+$G(^ACRDOC(ACRDOCDA,"PA"))
  1.  S ACRRA=$P($G(^ACRDOC(ACRDOCDA,"REQ2")),U,8)
  1.  ;S X=$S(X:$P(^VA(200,X,0),U),1:"")  ;ACR*2.1*19.02 IM16848
  1.  S X=$S(X:$$NAME2^ACRFUTL1(X),1:"")  ;ACR*2.1*19.02 IM16848
  1.  S ACRPURA=$P($P(X,",",2)," ")_" "_$P(X,",")
  1.  S ACRLBDA=$P(ACRDOC0,U,6)
  1.  S ACRDPTDA=$P(^ACRLOCB(ACRLBDA,0),U,5)
  1.  S:'ACRFLDA ACRFLDA=$P(^ACRDEPT(ACRDPTDA,0),U,2)
  1.  S ACRFL=$G(^ACRFSCD(+ACRFLDA,0))
  1.  S ACRFLRQ=$P(ACRFL,U,2)
  1.  S ACRFUND=$P(ACRFL,U,3)
  1.  S ACRPODA=$P(^AUTTPRG(ACRDPTDA,0),U,5)
  1.  S ACRPOFON=$S(ACRPODA:$P(^ACRPO(ACRPODA,0),U,9),1:"NOT STATED")
  1.  I 'ACRFINDA,ACRPODA S ACRFINDA=$P(^ACRPO(ACRPODA,0),U,8)
  1.  S ACRFL=$G(^ACRFSCD(+ACRFINDA,0))
  1.  S ACRFINRQ=$P(ACRFL,U,2)
  1.  S ACRRDATE=$P(ACRDOCPO,U,12)
  1.  I ACRRDATE D
  1.  .S X=$E(DT,1,3)_"0101"
  1.  .D H^%DTC
  1.  .S ACRFY=%H,X=ACRRDATE
  1.  .D H^%DTC
  1.  .S X=%H+1-ACRFY
  1.  .S X=$S($L(X)=1:"00"_X,$L(X)=2:"0"_X,1:X)
  1.  .S ACRRDATE=X
  1.  S X1=$P(ACRDOC0,U,3)+1
  1.  S X2=$E($P(ACRDOC0,U,3),1,3)_"0101"
  1.  D ^%DTC
  1.  S ACRJDATE=$P(ACRDOC0,U,26)
  1.  Q
  1. L W $$DASH^ACRFMENU
  1.  Q
  1. L4 W !,ACRI
  1.  W ?3,"|",ACRNSN
  1.  W ?11,"|",$E(ACRSSDC1,1,28)
  1.  W ?42,"|",ACRUI
  1.  W ?48,"|",ACRRQD
  1.  W ?54,"|",$J($FN(ACRUC,"P",2),12)
  1.  W ?67,"|",$J($FN(ACRRQD*ACRUC,"P",2),12)
  1. L3 W !,"---|-------|------------------------------|-----|-----|------------|------------"
  1.  Q
  1. DISP ;TO DISPLAY CUSTOMER ADDRESS
  1.  N DXS,DIP
  1.  W !,"10a. "
  1.  I $G(ACRRA) D
  1.  .;S X=$P($G(^VA(200,ACRRA,0)),U)  ;ACR*2.1*19.02 IM16848
  1.  .S X=$$NAME2^ACRFUTL1(ACRRA)  ;ACR*2.1*19.02 IM16848
  1.  .S X=$P($P(X,",",2)," ")_" "_$P(X,",")
  1.  .W X
  1.  .W ?45,"10b. PHONE: ",$P(^ACRDOC(ACRDOCDA,"REQ"),U,8)
  1.  W !,"11 CUSTOMER ADDRESS"
  1.  D COMADD
  1.  W !,"12. ACTIVITY ADDRESS CODE"
  1.  W !?5,ACRFLRQ
  1.  W !,"13. AGENCY ACCESS CODE"
  1.  W !?5
  1.  W:$P($G(^ACRDOC(ACRDOCDA,18)),U,2)]"" $P(^(18),U,2)
  1.  D PAUSE^ACRFWARN
  1.  Q
  1.  W @IOF
  1.  D L
  1.  W !
  1.  I $E($G(IOST),1,2)="C-" W "ARMS REF: ",$P(^ACRDOC(ACRDOCDA,0),U,6),"/",ACRDOCDA
  1.  W ?20,"CUSTOMER SUPPLY CENTER ORDER"
  1.  W ?60,"DATE: "
  1.  S Y=DT
  1.  X ^DD("DD")
  1.  W Y
  1.  D L
  1.  W !,"If limited quantities are used, local reproduction is authorized.  Otherwise"
  1.  W !,"obtain supplies from the National Forms and Publications Center."
  1.  D L
  1.  W !,"FOR CSC USE ONLY"
  1.  W !
  1.  W:$P($G(^ACRDOC(ACRDOCDA,18)),U)]"" "CSC TICKET NUMBER: ",$P(^(18),U)
  1.  D L
  1.  W !,"DOCUMENT #: ",$P(^ACRDOC(ACRDOCDA,0),U)," (",$P(^(0),U,2),")"
  1.  F I=42,48,54,67 W ?I,"|" ;ACR*2.1*14.01 IM12272
  1.  W !?4,"DHHS #: ",$$EXPDN^ACRFUTL(ACRDOCDA) ;ACR*2.1*14.01 IM12272
  1.  W ?42,"| UNIT"
  1.  W ?48,"| 4."
  1.  W ?54,"|  5."
  1.  W ?67,"|6. EXTENDED"
  1.  W !,"------------------------------------------|  OF"
  1.  W ?48,"| QUAN"
  1.  W ?54,"|  UNIT"
  1.  W ?67,"|    PRICE"
  1.  W !,"1. ITEM #"
  1.  W ?11,"|  2. ITEM DESCRIPTION"
  1.  W ?42,"|ISSUE"
  1.  W ?48,"| TITY"
  1.  W ?54,"|  PRICE "
  1.  W ?67,"|   ESTIMATED"
  1.  D L
  1.  Q
  1. COMADD ;EP;TO PRINT CUSTOMER ADDRESS AND SHIP TO ADDRESS
  1.  N ACRST
  1.  S ACRST=+$G(^ACRDOC(ACRDOCDA,"POST"))
  1.  I ACRST=ACRDPTDA D  Q
  1.  .S D0=ACRDPTDA
  1.  .D ^ACRPDA
  1.  W !?3,"ORDERED BY: ",$P(^AUTTPRG(ACRDPTDA,0),U)
  1.  W !?3,"SHIP TO...:"
  1.  S D0=ACRST
  1.  D ^ACRPDA
  1.  Q