- ACRF1449 ;IHS/OIRM/DSD/THL,AEF - SOLICITATION FOR COMMERCIAL ITEMS; [ 09/22/2005 9:44 AM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
- EN D ^ACRFSSPO,EN1
- EXIT K ACRX,ACR7A,ACR7B,ACR13A,ACR13B,ACR17B,ACR18B,ACR27A,ACR27A1,ACR27B,ACR27B1,ACREFFD
- F X=1:1:18 K @("ACR"_X)
- Q
- EN1 D GATHER
- D ^ACRF1441:'$D(ACRORIGF)
- D ^ACRF1442:$D(ACRORIGF)
- Q
- GATHER ;GATHER ALL INFO REQUIRED TO PRINT THE DOCUMENT
- D SETDOC^ACRFEA1
- S ACRPO=$G(^ACRDOC(ACRDOCDA,"PO"))
- S ACR9=$G(^ACRDOC(ACRDOCDA,"POIO"))
- S ACR15=$G(^ACRDOC(ACRDOCDA,"POST"))
- S ACR18=$G(^ACRDOC(ACRDOCDA,"POMI"))
- S ACR26=$G(^ACRDOC(ACRDOCDA,26))
- S ACR33=$G(^ACRDOC(ACRDOCDA,33))
- S ACR21=$G(^ACRDOC(ACRDOCDA,21))
- S ACR17=$P(ACRPO,U,5)
- S ACR5=$P(ACR33,U,3)
- S X=$P(ACR33,U,2)
- S ACR6=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
- S X=$P(ACR33,U,11)
- S ACR8=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
- S X=$G(^AUTTPRG(+ACR9,"DT"))
- S ACR9(1)=$P($G(^AUTTPRG(+ACR9,0)),U)
- S ACR9(2)=$P(X,U)
- S ACR9(3)=$P(X,U,2)
- S ACR9(4)=$P(X,U,3)
- S ACR9(5)=$P(X,U,4)
- S ACR9(6)=$P(X,U,5)
- S ACR9(7)=$P(X,U,6)
- S ACR9(5)=$P($G(^DIC(5,+ACR9(5),0)),U,2)
- DELIVER S X=$G(^AUTTPRG(+ACR15,"DT"))
- S ACR15(1)=$P($G(^AUTTPRG(+ACR15,0)),U)
- S ACR15(2)=$P(X,U)
- S ACR15(3)=$P(X,U,2)
- S ACR15(4)=$P(X,U,3)
- S ACR15(5)=$P(X,U,4)
- S ACR15(6)=$P(X,U,5)
- S ACR15(7)=$P(X,U,6)
- S ACR15(5)=$P($G(^DIC(5,+ACR15(5),0)),U,2)
- ADMIN S X=$G(^AUTTPRG(+$P(ACR26,U,6),"DT"))
- S ACR16(1)=$P($G(^AUTTPRG(+$P(ACR26,U,6),0)),U)
- S ACR16(2)=$P(X,U)
- S ACR16(3)=$P(X,U,2)
- S ACR16(4)=$P(X,U,3)
- S ACR16(5)=$P(X,U,4)
- S ACR16(6)=$P(X,U,5)
- S ACR16(7)=$P(X,U,6)
- S ACR16(5)=$P($G(^DIC(5,+ACR16(5),0)),U,2)
- VENDOR ;
- S X=$G(^AUTTVNDR(+ACR17,11))
- S ACR17(1)=$P($G(^AUTTVNDR(+ACR17,0)),U)
- S ACR17(7)=$P(X,U,13)
- S X=$G(^AUTTVNDR(+ACR17,13))
- S ACR17(2)=$P(X,U)
- S ACR17(3)=$P(X,U,10)
- S ACR17(4)=$P(X,U,2)
- S ACR17(5)=$P(X,U,3)
- S ACR17(6)=$P(X,U,4)
- S ACR17(5)=$P($G(^DIC(5,+ACR17(5),0)),U,2)
- PAY S X=$G(^AUTTPRG(+ACR18,"DT"))
- S ACR18(1)=$P($G(^AUTTPRG(+ACR18,0)),U)
- S ACR18(2)=$P(X,U)
- S ACR18(3)=$P(X,U,2)
- S ACR18(4)=$P(X,U,3)
- S ACR18(5)=$P(X,U,4)
- S ACR18(6)=$P(X,U,5)
- S ACR18(7)=$P(X,U,6)
- S ACR18(5)=$P($G(^DIC(5,+ACR18(5),0)),U,2)
- S ACR1=$P(ACRDOC0,U)
- S ACR2=$P(ACRDOC0,U,2)
- S Y=$P(ACRPO,U)
- X ^DD("DD")
- S (ACR3,ACREFFD)=Y
- S ACR4=$P(ACRPO,U,3)
- S ACR7A=+$G(^ACRDOC(ACRDOCDA,"PA"))
- S ACR7B=$P($G(^ACRPO(+$G(ACRPODA),0)),U,9)
- ;S X=$P($G(^VA(200,+ACR7A,0)),U) ;ACR*2.1*19.02 IM16848
- S X=$$NAME2^ACRFUTL1(+ACR7A) ;ACR*2.1*19.02 IM16848
- S X=$P($P(X,",",2)," ")_" "_$P(X,",")
- S ACR7A=X
- S ACR12=$P(ACRPO,U,13)
- S ACR13A=$S($P(ACR26,0):"XX",1:"")
- S ACR13B=$P(ACR26,U)
- Q
- DISP ;EP;
- D DISP^ACRF1442
- Q
- 33030(X) S X=$P(ACR33,U,3)
- Q X
- ACRF1449 ;IHS/OIRM/DSD/THL,AEF - SOLICITATION FOR COMMERCIAL ITEMS; [ 09/22/2005 9:44 AM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
- EN DO ^ACRFSSPO
- DO EN1
- EXIT KILL ACRX,ACR7A,ACR7B,ACR13A,ACR13B,ACR17B,ACR18B,ACR27A,ACR27A1,ACR27B,ACR27B1,ACREFFD
- +1 FOR X=1:1:18
- KILL @("ACR"_X)
- +2 QUIT
- EN1 DO GATHER
- +1 IF '$DATA(ACRORIGF)
- DO ^ACRF1441
- +2 IF $DATA(ACRORIGF)
- DO ^ACRF1442
- +3 QUIT
- GATHER ;GATHER ALL INFO REQUIRED TO PRINT THE DOCUMENT
- +1 DO SETDOC^ACRFEA1
- +2 SET ACRPO=$GET(^ACRDOC(ACRDOCDA,"PO"))
- +3 SET ACR9=$GET(^ACRDOC(ACRDOCDA,"POIO"))
- +4 SET ACR15=$GET(^ACRDOC(ACRDOCDA,"POST"))
- +5 SET ACR18=$GET(^ACRDOC(ACRDOCDA,"POMI"))
- +6 SET ACR26=$GET(^ACRDOC(ACRDOCDA,26))
- +7 SET ACR33=$GET(^ACRDOC(ACRDOCDA,33))
- +8 SET ACR21=$GET(^ACRDOC(ACRDOCDA,21))
- +9 SET ACR17=$PIECE(ACRPO,U,5)
- +10 SET ACR5=$PIECE(ACR33,U,3)
- +11 SET X=$PIECE(ACR33,U,2)
- +12 SET ACR6=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
- +13 SET X=$PIECE(ACR33,U,11)
- +14 SET ACR8=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
- +15 SET X=$GET(^AUTTPRG(+ACR9,"DT"))
- +16 SET ACR9(1)=$PIECE($GET(^AUTTPRG(+ACR9,0)),U)
- +17 SET ACR9(2)=$PIECE(X,U)
- +18 SET ACR9(3)=$PIECE(X,U,2)
- +19 SET ACR9(4)=$PIECE(X,U,3)
- +20 SET ACR9(5)=$PIECE(X,U,4)
- +21 SET ACR9(6)=$PIECE(X,U,5)
- +22 SET ACR9(7)=$PIECE(X,U,6)
- +23 SET ACR9(5)=$PIECE($GET(^DIC(5,+ACR9(5),0)),U,2)
- DELIVER SET X=$GET(^AUTTPRG(+ACR15,"DT"))
- +1 SET ACR15(1)=$PIECE($GET(^AUTTPRG(+ACR15,0)),U)
- +2 SET ACR15(2)=$PIECE(X,U)
- +3 SET ACR15(3)=$PIECE(X,U,2)
- +4 SET ACR15(4)=$PIECE(X,U,3)
- +5 SET ACR15(5)=$PIECE(X,U,4)
- +6 SET ACR15(6)=$PIECE(X,U,5)
- +7 SET ACR15(7)=$PIECE(X,U,6)
- +8 SET ACR15(5)=$PIECE($GET(^DIC(5,+ACR15(5),0)),U,2)
- ADMIN SET X=$GET(^AUTTPRG(+$PIECE(ACR26,U,6),"DT"))
- +1 SET ACR16(1)=$PIECE($GET(^AUTTPRG(+$PIECE(ACR26,U,6),0)),U)
- +2 SET ACR16(2)=$PIECE(X,U)
- +3 SET ACR16(3)=$PIECE(X,U,2)
- +4 SET ACR16(4)=$PIECE(X,U,3)
- +5 SET ACR16(5)=$PIECE(X,U,4)
- +6 SET ACR16(6)=$PIECE(X,U,5)
- +7 SET ACR16(7)=$PIECE(X,U,6)
- +8 SET ACR16(5)=$PIECE($GET(^DIC(5,+ACR16(5),0)),U,2)
- VENDOR ;
- +1 SET X=$GET(^AUTTVNDR(+ACR17,11))
- +2 SET ACR17(1)=$PIECE($GET(^AUTTVNDR(+ACR17,0)),U)
- +3 SET ACR17(7)=$PIECE(X,U,13)
- +4 SET X=$GET(^AUTTVNDR(+ACR17,13))
- +5 SET ACR17(2)=$PIECE(X,U)
- +6 SET ACR17(3)=$PIECE(X,U,10)
- +7 SET ACR17(4)=$PIECE(X,U,2)
- +8 SET ACR17(5)=$PIECE(X,U,3)
- +9 SET ACR17(6)=$PIECE(X,U,4)
- +10 SET ACR17(5)=$PIECE($GET(^DIC(5,+ACR17(5),0)),U,2)
- PAY SET X=$GET(^AUTTPRG(+ACR18,"DT"))
- +1 SET ACR18(1)=$PIECE($GET(^AUTTPRG(+ACR18,0)),U)
- +2 SET ACR18(2)=$PIECE(X,U)
- +3 SET ACR18(3)=$PIECE(X,U,2)
- +4 SET ACR18(4)=$PIECE(X,U,3)
- +5 SET ACR18(5)=$PIECE(X,U,4)
- +6 SET ACR18(6)=$PIECE(X,U,5)
- +7 SET ACR18(7)=$PIECE(X,U,6)
- +8 SET ACR18(5)=$PIECE($GET(^DIC(5,+ACR18(5),0)),U,2)
- +9 SET ACR1=$PIECE(ACRDOC0,U)
- +10 SET ACR2=$PIECE(ACRDOC0,U,2)
- +11 SET Y=$PIECE(ACRPO,U)
- +12 XECUTE ^DD("DD")
- +13 SET (ACR3,ACREFFD)=Y
- +14 SET ACR4=$PIECE(ACRPO,U,3)
- +15 SET ACR7A=+$GET(^ACRDOC(ACRDOCDA,"PA"))
- +16 SET ACR7B=$PIECE($GET(^ACRPO(+$GET(ACRPODA),0)),U,9)
- +17 ;S X=$P($G(^VA(200,+ACR7A,0)),U) ;ACR*2.1*19.02 IM16848
- +18 ;ACR*2.1*19.02 IM16848
- SET X=$$NAME2^ACRFUTL1(+ACR7A)
- +19 SET X=$PIECE($PIECE(X,",",2)," ")_" "_$PIECE(X,",")
- +20 SET ACR7A=X
- +21 SET ACR12=$PIECE(ACRPO,U,13)
- +22 SET ACR13A=$SELECT($PIECE(ACR26,0):"XX",1:"")
- +23 SET ACR13B=$PIECE(ACR26,U)
- +24 QUIT
- DISP ;EP;
- +1 DO DISP^ACRF1442
- +2 QUIT
- 33030(X) SET X=$PIECE(ACR33,U,3)
- +1 QUIT X
