| 1 | PRCHHI0 ;WISC/TGH-IFCAP CONTROL STRING SEGMENT ;5/19/92 3:17 PM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | CNTL(A,A1,A2,CNTR) N B,I,JD,X,Y
|
|---|
| 6 | S PRCHA=A,PRCHTC=A2
|
|---|
| 7 | D NOW^%DTC S X=$P(%,".") D JD^PRCFDLN S PRCHJD=$E(X,1,3)+1700_$E(Y,1,3)
|
|---|
| 8 | S TIME=$P(%,".",2)_"000000",TIME=$E(TIME,1,6)
|
|---|
| 9 | S PRCHTP(1,CNTR+1)="S X=PRCHSYS;500"
|
|---|
| 10 | S PRCHTP(1,CNTR+2)="S X=+$P(PRCHA,U);1"
|
|---|
| 11 | S PRCHTP(1,CNTR+3)="S X=200;63"
|
|---|
| 12 | S PRCHTP(1,CNTR+4)="S X=PRCHTC;430"
|
|---|
| 13 | S PRCHTP(1,CNTR+5)="S X=PRCHJD;501"
|
|---|
| 14 | S PRCHTP(1,CNTR+6)="S X=TIME;502"
|
|---|
| 15 | S PRCHPON=$P($P(PRCHA,U),""-"")_$P($P(PRCHA,U),""-"",2)
|
|---|
| 16 | S PRCHPON=PRCHPON_" ",PRCHPON=$E(PRCHPON,1,11)
|
|---|
| 17 | S PRCHTP(1,CNTR+7)="S X=PRCHPON;503"
|
|---|
| 18 | S PRCHTP(1,CNTR+8)="S X=""001"";503.1"
|
|---|
| 19 | S PRCHTP(1,CNTR+9)="S X=""001"";503.2"
|
|---|
| 20 | S PRCHTP(1,CNTR+10)="S X=""001"";504"
|
|---|
| 21 | S CNTR=CNTR+10
|
|---|
| 22 | S PRCFA("STRING")=""
|
|---|
| 23 | S PRCFA("STRING")=PRCHSYS_"^"_+$P(PRCHA,U)_"^200^"_PRCHTC_"^"_PRCHJD_"^"_TIME_"^"_$P($P(PRCHA,U),"-")_$P($P(PRCHA,U),"-",2)_" "_"^001^001^040^|"
|
|---|
| 24 | Q
|
|---|
