91 lines
2.9 KiB
Mathematica
91 lines
2.9 KiB
Mathematica
PRCHHI ;WISC/TGH-IFCAP EDI ENTRY ROUTINE ;1/30/98 1100
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
Q
|
|
NEW(VAR1,PRCHTYP,PRCHPAR) ; VAR1 = Record Number
|
|
; PRCHTYP = Transaction Type
|
|
; PRCHPAR = Partial Number if type is RC1
|
|
;
|
|
N A,A1,A2,TC,PRCHTYPE,CNTR,NUM,KEPNUM
|
|
S U="^"
|
|
S A=$G(^PRC(442,VAR1,0)) Q:A="" S ZA=A S PRC("SITE")=$P($P(A,U),"-")
|
|
S YR=$E(DT,2,3),MO=$E(DT,4,5),PRC("FY")=$E(100+$S(MO>9:YR+1,1:YR),2,3)
|
|
S A1=$G(^PRC(442,VAR1,1)) S ZA1=A1 Q:A1=""
|
|
;N A6 S A6=$G(^PRC(442,VAR1,6,0)) I A6]"" G:$P(A6,U,4)>0 POM
|
|
K PRCHTP
|
|
S (CNTR,NUM)=0
|
|
S PRCHTP(1)="442,"_VAR1_",^PRC(442,"
|
|
S PRCHTYPE=$E(PRCHTYP)
|
|
S PRCFA("TT")=PRCHTYP,(PRCFA("SYS"),PRCHSYS)="ISM",PRCFASYS="ISM"
|
|
K ^TMP($J)
|
|
W !!,"Now building Code sheet..."
|
|
I PRCHTYPE="R" D RECT
|
|
I PRCHTYPE="P" D OBL
|
|
I $F("ST",$E(PRCHTYPE)) D REQ
|
|
S NUM=NUM+1,^TMP($J,"STRING",NUM)="$"
|
|
;
|
|
W !!,"Now Transmitting Code sheet..."
|
|
S W1=PRC("SITE"),W2="PO1",V3=$P($P(A,U),"-")_$P($P(A,U),"-",2),V4="IST",V5=200
|
|
D TRANSMIT^PRCPSMCS(W1,W2,V3,V4,V5) S XMZ=$O(PRCPXMZ(0)) I XMZ>0 S $P(^PRC(442,VAR1,12),U,10)=PRCPXMZ(XMZ)
|
|
;S PRC("PER")=$P(A1,U,10),PRCFA("TTF")="ISM" D ^PRCFACX2
|
|
;S CSDA=PRCFA("CSDA") D ^PRCFACB Q:'$D(PRCF("BTCH"))
|
|
;N PRCOPODA S PRCOPODA=VAR1 D ^PRCFACBT S ZTREQ="@"
|
|
K PRCHTP,PRCHTP1 ;use if we do not build 423
|
|
Q
|
|
REQ ;Requistion
|
|
S TC=$P(A,U,19),A2=$P(A1,U,9)
|
|
S A2=$S(A2="ST":1,A2="SP":2,A2="EM":3,1:1)
|
|
I TC'=2 S TC="SO"
|
|
E S TC="TO"
|
|
S A2=TC_A2
|
|
S PRCFA("TT")=A2,PRCFA("SYS")="ISM",PRCFASYS="ISM"
|
|
D CNTL^PRCHHI0(A,A1,A2,.CNTR)
|
|
S PRCHSYS="ISM"
|
|
D CNTL^PRCHHI0(A,A1,A2,.CNTR)
|
|
D HE^PRCHHI1(A,A1,A2,VAR1,.CNTR,.NUM)
|
|
D CU^PRCHHI3(A,.CNTR,.NUM)
|
|
D BI^PRCHHI2(A,A2,VAR1,.CNTR,.NUM)
|
|
D ST^PRCHHI4(A,A1,A2,.CNTR,.NUM)
|
|
D AC^PRCHHI5(A,A1,VAR1,.CNTR,.NUM)
|
|
S PRCHVAR1=VAR1
|
|
;S PRCHTP(1,CNTR+1)="D IT^PRCHHI6(PRCHVAR1) S X=""|$"";507"
|
|
D IT^PRCHHI6(PRCHVAR1,.NUM)
|
|
S PRCHLI="QUIT"
|
|
Q
|
|
;KILL VARS
|
|
RECT ;
|
|
D CNTL^PRCHHI0(A,A1,PRCHTYP,.CNTR)
|
|
D DH^PRCHHI8(A,A1,PRCHTYP,VAR1,.CNTR,.NUM)
|
|
S PRCHVAR1=VAR1,PRCHPAR1=PRCHPAR
|
|
;S PRCHTP(1,CNTR+1)="D DL^PRCHHI10(PRCHVAR1,PRCHPAR1) S X=""|$"";507"
|
|
D DL^PRCHHI10(PRCHVAR1,PRCHPAR1,.NUM)
|
|
Q
|
|
OBL ;
|
|
S PRCFA("SYS")="ISM"
|
|
D CNTL^PRCHHI0(A,A1,PRCHTYP,.CNTR)
|
|
D AC^PRCHHI5(A,A1,VAR1,.CNTR,.NUM)
|
|
D DH^PRCHHI8(A,A1,PRCHTYP,VAR1,.CNTR,.NUM)
|
|
;The following line picks up comments
|
|
S A2=4,A3="CO",ITEM=""
|
|
S KEPNUM=NUM
|
|
;S PRCHTP(1,CNTR+1)="D CO^PRCHHI9(4,""CO"",PRCHPO,ITEM,.NUM) S X=""|$"";507"
|
|
;D CO^PRCHHI9(4,"CO",PRCHPO,ITEM,.NUM)
|
|
D CO^PRCHHI9(4,"CO",VAR1,ITEM,.NUM)
|
|
;
|
|
;#DE SEGMENT(NUMBER DESC'S OF DH SEGMENT) FORMATTED UPTO 3 CHARS
|
|
S PRCHNUM=NUM-KEPNUM
|
|
S PRCHNUM="00"_PRCHNUM
|
|
S PRCHNUM=$E(PRCHNUM,$L(PRCHNUM)-2,99)
|
|
;
|
|
S $P(^TMP($J,"STRING",KEPNUM),U,21)=PRCHNUM
|
|
;The following is for items and decriptions
|
|
;S PRCHTP(1,CNTR+2)="D DL^PRCHHI7(PRCHA,PRCHPO,.NUM) S X=""|$"";507"
|
|
S DLCNT=0
|
|
;D DL^PRCHHI7(PRCHA,PRCHPO,.NUM,.DLCNT)
|
|
D DL^PRCHHI7(PRCHA,VAR1,.NUM,.DLCNT)
|
|
;
|
|
;S $P(^TMP($J,"STRING",KEPNUM),U,22)=DLCNT
|
|
Q
|
|
POM ;
|
|
Q
|