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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHHI 3089 printed Sep 23, 2025@19:43:49 Page 2
PRCHHI ;WISC/TGH-IFCAP EDI ENTRY ROUTINE ;1/30/98 1100
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
NEW(VAR1,PRCHTYP,PRCHPAR) ; VAR1 = Record Number
+1 ; PRCHTYP = Transaction Type
+2 ; PRCHPAR = Partial Number if type is RC1
+3 ;
+4 NEW A,A1,A2,TC,PRCHTYPE,CNTR,NUM,KEPNUM
+5 SET U="^"
+6 SET A=$GET(^PRC(442,VAR1,0))
if A=""
QUIT
SET ZA=A
SET PRC("SITE")=$PIECE($PIECE(A,U),"-")
+7 SET YR=$EXTRACT(DT,2,3)
SET MO=$EXTRACT(DT,4,5)
SET PRC("FY")=$EXTRACT(100+$SELECT(MO>9:YR+1,1:YR),2,3)
+8 SET A1=$GET(^PRC(442,VAR1,1))
SET ZA1=A1
if A1=""
QUIT
+9 ;N A6 S A6=$G(^PRC(442,VAR1,6,0)) I A6]"" G:$P(A6,U,4)>0 POM
+10 KILL PRCHTP
+11 SET (CNTR,NUM)=0
+12 SET PRCHTP(1)="442,"_VAR1_",^PRC(442,"
+13 SET PRCHTYPE=$EXTRACT(PRCHTYP)
+14 SET PRCFA("TT")=PRCHTYP
SET (PRCFA("SYS"),PRCHSYS)="ISM"
SET PRCFASYS="ISM"
+15 KILL ^TMP($JOB)
+16 WRITE !!,"Now building Code sheet..."
+17 IF PRCHTYPE="R"
DO RECT
+18 IF PRCHTYPE="P"
DO OBL
+19 IF $FIND("ST",$EXTRACT(PRCHTYPE))
DO REQ
+20 SET NUM=NUM+1
SET ^TMP($JOB,"STRING",NUM)="$"
+21 ;
+22 WRITE !!,"Now Transmitting Code sheet..."
+23 SET W1=PRC("SITE")
SET W2="PO1"
SET V3=$PIECE($PIECE(A,U),"-")_$PIECE($PIECE(A,U),"-",2)
SET V4="IST"
SET V5=200
+24 DO TRANSMIT^PRCPSMCS(W1,W2,V3,V4,V5)
SET XMZ=$ORDER(PRCPXMZ(0))
IF XMZ>0
SET $PIECE(^PRC(442,VAR1,12),U,10)=PRCPXMZ(XMZ)
+25 ;S PRC("PER")=$P(A1,U,10),PRCFA("TTF")="ISM" D ^PRCFACX2
+26 ;S CSDA=PRCFA("CSDA") D ^PRCFACB Q:'$D(PRCF("BTCH"))
+27 ;N PRCOPODA S PRCOPODA=VAR1 D ^PRCFACBT S ZTREQ="@"
+28 ;use if we do not build 423
KILL PRCHTP,PRCHTP1
+29 QUIT
REQ ;Requistion
+1 SET TC=$PIECE(A,U,19)
SET A2=$PIECE(A1,U,9)
+2 SET A2=$SELECT(A2="ST":1,A2="SP":2,A2="EM":3,1:1)
+3 IF TC'=2
SET TC="SO"
+4 IF '$TEST
SET TC="TO"
+5 SET A2=TC_A2
+6 SET PRCFA("TT")=A2
SET PRCFA("SYS")="ISM"
SET PRCFASYS="ISM"
+7 DO CNTL^PRCHHI0(A,A1,A2,.CNTR)
+8 SET PRCHSYS="ISM"
+9 DO CNTL^PRCHHI0(A,A1,A2,.CNTR)
+10 DO HE^PRCHHI1(A,A1,A2,VAR1,.CNTR,.NUM)
+11 DO CU^PRCHHI3(A,.CNTR,.NUM)
+12 DO BI^PRCHHI2(A,A2,VAR1,.CNTR,.NUM)
+13 DO ST^PRCHHI4(A,A1,A2,.CNTR,.NUM)
+14 DO AC^PRCHHI5(A,A1,VAR1,.CNTR,.NUM)
+15 SET PRCHVAR1=VAR1
+16 ;S PRCHTP(1,CNTR+1)="D IT^PRCHHI6(PRCHVAR1) S X=""|$"";507"
+17 DO IT^PRCHHI6(PRCHVAR1,.NUM)
+18 SET PRCHLI="QUIT"
+19 QUIT
+20 ;KILL VARS
RECT ;
+1 DO CNTL^PRCHHI0(A,A1,PRCHTYP,.CNTR)
+2 DO DH^PRCHHI8(A,A1,PRCHTYP,VAR1,.CNTR,.NUM)
+3 SET PRCHVAR1=VAR1
SET PRCHPAR1=PRCHPAR
+4 ;S PRCHTP(1,CNTR+1)="D DL^PRCHHI10(PRCHVAR1,PRCHPAR1) S X=""|$"";507"
+5 DO DL^PRCHHI10(PRCHVAR1,PRCHPAR1,.NUM)
+6 QUIT
OBL ;
+1 SET PRCFA("SYS")="ISM"
+2 DO CNTL^PRCHHI0(A,A1,PRCHTYP,.CNTR)
+3 DO AC^PRCHHI5(A,A1,VAR1,.CNTR,.NUM)
+4 DO DH^PRCHHI8(A,A1,PRCHTYP,VAR1,.CNTR,.NUM)
+5 ;The following line picks up comments
+6 SET A2=4
SET A3="CO"
SET ITEM=""
+7 SET KEPNUM=NUM
+8 ;S PRCHTP(1,CNTR+1)="D CO^PRCHHI9(4,""CO"",PRCHPO,ITEM,.NUM) S X=""|$"";507"
+9 ;D CO^PRCHHI9(4,"CO",PRCHPO,ITEM,.NUM)
+10 DO CO^PRCHHI9(4,"CO",VAR1,ITEM,.NUM)
+11 ;
+12 ;#DE SEGMENT(NUMBER DESC'S OF DH SEGMENT) FORMATTED UPTO 3 CHARS
+13 SET PRCHNUM=NUM-KEPNUM
+14 SET PRCHNUM="00"_PRCHNUM
+15 SET PRCHNUM=$EXTRACT(PRCHNUM,$LENGTH(PRCHNUM)-2,99)
+16 ;
+17 SET $PIECE(^TMP($JOB,"STRING",KEPNUM),U,21)=PRCHNUM
+18 ;The following is for items and decriptions
+19 ;S PRCHTP(1,CNTR+2)="D DL^PRCHHI7(PRCHA,PRCHPO,.NUM) S X=""|$"";507"
+20 SET DLCNT=0
+21 ;D DL^PRCHHI7(PRCHA,PRCHPO,.NUM,.DLCNT)
+22 DO DL^PRCHHI7(PRCHA,VAR1,.NUM,.DLCNT)
+23 ;
+24 ;S $P(^TMP($J,"STRING",KEPNUM),U,22)=DLCNT
+25 QUIT
POM ;
+1 QUIT
