- 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 Jan 18, 2025@03:08:56 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