PRCHRATA ;SF/TKW/WISC/CLH/DL-PUBLIC LAW 100-322 REPORT--CONTINUED ;1/30/98 1315
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
IFC ;IFC CONTROL STRING FROM STATION 'PRC("SITE")' TO AUSTIN, TEXAS FOR '322' TRANSACTION
N %,B,JD,TIME,X,Y Q:$$S^%ZTLOAD
S B="IFC^"_PRC("SITE")_"^200^322^" D NOW^%DTC S X=$P(%,".") D JD^PRCFDLN
S JD=$E(X,1,3)+1700_$E(Y,1,3),TIME=$P(%,".",2)_"000000",TIME=$E(TIME,1,6),B=B_JD_"^"_TIME_"^"_" "_"^001^001^001^|",PRCFA("STRING")=B
Q
;
RH ;REPORT HEADER 'RH' SEGMENT OF '322' TRANSACTION
; ^ PIECE 2 = TOTAL 'AD' SEGMENTS IN TRANSACTION
; ^ PIECE 3 = TOTAL 'SU' SEGMENTS IN TRANSACTION
N B Q:$$S^%ZTLOAD
S B="RH^^^|",^TMP($J,"STRING",1)=B
Q
;
EN ;DETAILED REPORT 'AD' SEGMENT OF '322' TRANSACTION
N B,FRJD,HCT,HCT1,HCT2,L,LCT,LCT1,LCT2,NIIN,PRCHDESC,PRCHFSC,PRCHSEG,PRCHSRC,PRCHV,QTY,T1,T2,TOJD,TOTAL,X,Y
Q:$$S^%ZTLOAD
S X=FR D JD^PRCFDLN S FRJD=$E(X,1,3)+1700_$E(Y,1,3),X=TO D JD^PRCFDLN S TOJD=$E(X,1,3)+1700_$E(Y,1,3)
S PRCHFSC="",PRCHSEG=0 F S PRCHFSC=$O(^TMP($J,"R",PRCHFSC)) Q:PRCHFSC="" D
RD1 .S PRCHDESC=0 F S PRCHDESC=$O(^TMP($J,"R",PRCHFSC,PRCHDESC)) Q:PRCHDESC="" D
RD2 ..S (PRCHV,L)="" F S PRCHV=$O(^TMP($J,"R",PRCHFSC,PRCHDESC,PRCHV)) Q:PRCHV="" F S L=$O(^TMP($J,"R",PRCHFSC,PRCHDESC,PRCHV,L)) Q:L="" S PRCHSRC="" D
... F S PRCHSRC=$O(^TMP($J,"R",PRCHFSC,PRCHDESC,PRCHV,L,PRCHSRC)) Q:PRCHSRC="" S X=^(PRCHSRC) I "2B"[$P(X,U,9) D
....S PRCHSEG=PRCHSEG+1,QTY=$P(X,U,4)\1,NIIN=$S($P(X,U,2)=0:"",1:$P(X,U,2)),B="AD^"_PRCHSEG_"^"_FRJD_"^"_TOJD_"^"_PRCHDESC_"^"_$P(X,U,12)_"^"_PRCHFSC_"^"_NIIN_"^"_QTY_"^"_PRCHV_"^"
....S TOTAL=$P(X,U,6) I TOTAL["." S T1=$P(TOTAL,"."),T2=$P(TOTAL,".",2)_"00",T2=$E(T2,1,2),TOTAL=T1_T2 G RD3
....S TOTAL=TOTAL_"00"
RD3 ....S LCT=$P(X,U,10) I LCT["." S LCT1=$P(LCT,"."),LCT2=$P(LCT,".",2)_"00",LCT2=$E(LCT2,1,2),LCT=LCT1_LCT2 G RD4
....S LCT=LCT_"00"
RD4 ....S HCT=$P(X,U,11) I HCT["." S HCT1=$P(HCT,"."),HCT2=$P(HCT,".",2)_"00",HCT2=$E(HCT2,1,2),HCT=HCT1_HCT2 G RD5
....S HCT=HCT_"00"
RD5 ....S B=B_TOTAL_"^"_LCT_"^"_HCT_"^|",COUNTER=COUNTER+1,^TMP($J,"STRING",COUNTER)=B Q
...Q
..Q
.Q
S X=^TMP($J,"STRING",1),$P(X,U,2)=PRCHSEG,^TMP($J,"STRING",1)=X
Q
;
EN2 ;SUMMARY TOTALS 'SU' SEGMENT OF '322' TRANSACTION
N AOM,AOM1,AOM2,B,FRJD,OME,OME1,OME2,PRCHFSC,PRCHSEG,T1,T2,TOJD,TOTAL,X,Y
Q:$$S^%ZTLOAD
S X=FR D JD^PRCFDLN S FRJD=$E(X,1,3)+1700_$E(Y,1,3),X=TO D JD^PRCFDLN S TOJD=$E(X,1,3)+1700_$E(Y,1,3)
S PRCHFSC="",PRCHSEG=0 F S PRCHFSC=$O(^TMP($J,"FSC",PRCHFSC)) Q:'PRCHFSC S X=^TMP($J,"FSC",PRCHFSC) D
.S PRCHSEG=PRCHSEG+1,B="SU^"_PRCHSEG_"^"_FRJD_"^"_TOJD_"^"_PRCHFSC_"^"
.S TOTAL=$P(X,U,2) I TOTAL["." S T1=$P(TOTAL,"."),T2=$P(TOTAL,".",2)_"00",T2=$E(T2,1,2),TOTAL=T1_T2 G RDA
.S TOTAL=TOTAL_"00"
RDA .S AOM=$P(X,U,3) I AOM["." S AOM1=$P(AOM,"."),AOM2=$P(AOM,".",2)_"00",AOM2=$E(AOM2,1,2),AOM=AOM1_AOM2 G RDB
.S AOM=AOM_"00"
RDB .S OME=$P(X,U,4) I OME["." S OME1=$P(OME,"."),OME2=$P(OME,".",2)_"00",OME2=$E(OME2,1,2),OME=OME1_OME2 G RDC
.S OME=OME_"00"
RDC .S B=B_TOTAL_"^"_AOM_"^"_OME_"^|",COUNTER=COUNTER+1,^TMP($J,"STRING",COUNTER)=B Q
S X=^TMP($J,"STRING",1),$P(X,U,3)=PRCHSEG,^TMP($J,"STRING",1)=X
Q
;
EN3 ;END OF TRANSACTION LINE AND TRANSMISSION ROUTINE CALLS
N %,%H,%I,CSDA,MO,PRCFASYS,TEST,YR,X Q:$$S^%ZTLOAD
S COUNTER=COUNTER+1,^TMP($J,"STRING",COUNTER)="$"
S PRCFASYS="PRC",PRCFA("TTF")="PRC" D NOW^%DTC S YR=$E(X,2,3),MO=$E(X,4,5)
S PRC("FY")=$E(100+$S(MO>9:YR+1,1:YR),2,3)
D ^PRCFACX2 K ^TMP($J,"STRING") S CSDA=PRCFA("CSDA") D ^PRCFACB Q:'$D(PRCF("BTCH")) S TEST=PRCF("BTCH"),PRCFA("ISM")="XXX@Q-PRC.DOMAIN.EXT" D ^PRCFACBT S ZTREQ="@"
I $D(PRCOUT),(PRCOUT>0) S ^TMP($J,"RESULTS")="NOMM" Q
S ^TMP($J,"RESULTS")="OK^"_TEST_"^"_CSDA K PRCOUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRATA 3805 printed Dec 13, 2024@02:10:07 Page 2
PRCHRATA ;SF/TKW/WISC/CLH/DL-PUBLIC LAW 100-322 REPORT--CONTINUED ;1/30/98 1315
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
IFC ;IFC CONTROL STRING FROM STATION 'PRC("SITE")' TO AUSTIN, TEXAS FOR '322' TRANSACTION
+1 NEW %,B,JD,TIME,X,Y
if $$S^%ZTLOAD
QUIT
+2 SET B="IFC^"_PRC("SITE")_"^200^322^"
DO NOW^%DTC
SET X=$PIECE(%,".")
DO JD^PRCFDLN
+3 SET JD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
SET TIME=$PIECE(%,".",2)_"000000"
SET TIME=$EXTRACT(TIME,1,6)
SET B=B_JD_"^"_TIME_"^"_" "_"^001^001^001^|"
SET PRCFA("STRING")=B
+4 QUIT
+5 ;
RH ;REPORT HEADER 'RH' SEGMENT OF '322' TRANSACTION
+1 ; ^ PIECE 2 = TOTAL 'AD' SEGMENTS IN TRANSACTION
+2 ; ^ PIECE 3 = TOTAL 'SU' SEGMENTS IN TRANSACTION
+3 NEW B
if $$S^%ZTLOAD
QUIT
+4 SET B="RH^^^|"
SET ^TMP($JOB,"STRING",1)=B
+5 QUIT
+6 ;
EN ;DETAILED REPORT 'AD' SEGMENT OF '322' TRANSACTION
+1 NEW B,FRJD,HCT,HCT1,HCT2,L,LCT,LCT1,LCT2,NIIN,PRCHDESC,PRCHFSC,PRCHSEG,PRCHSRC,PRCHV,QTY,T1,T2,TOJD,TOTAL,X,Y
+2 if $$S^%ZTLOAD
QUIT
+3 SET X=FR
DO JD^PRCFDLN
SET FRJD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
SET X=TO
DO JD^PRCFDLN
SET TOJD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
+4 SET PRCHFSC=""
SET PRCHSEG=0
FOR
SET PRCHFSC=$ORDER(^TMP($JOB,"R",PRCHFSC))
if PRCHFSC=""
QUIT
Begin DoDot:1
RD1 SET PRCHDESC=0
FOR
SET PRCHDESC=$ORDER(^TMP($JOB,"R",PRCHFSC,PRCHDESC))
if PRCHDESC=""
QUIT
Begin DoDot:2
RD2 SET (PRCHV,L)=""
FOR
SET PRCHV=$ORDER(^TMP($JOB,"R",PRCHFSC,PRCHDESC,PRCHV))
if PRCHV=""
QUIT
FOR
SET L=$ORDER(^TMP($JOB,"R",PRCHFSC,PRCHDESC,PRCHV,L))
if L=""
QUIT
SET PRCHSRC=""
Begin DoDot:3
+1 FOR
SET PRCHSRC=$ORDER(^TMP($JOB,"R",PRCHFSC,PRCHDESC,PRCHV,L,PRCHSRC))
if PRCHSRC=""
QUIT
SET X=^(PRCHSRC)
IF "2B"[$PIECE(X,U,9)
Begin DoDot:4
+2 SET PRCHSEG=PRCHSEG+1
SET QTY=$PIECE(X,U,4)\1
SET NIIN=$SELECT($PIECE(X,U,2)=0:"",1:$PIECE(X,U,2))
SET B="AD^"_PRCHSEG_"^"_FRJD_"^"_TOJD_"^"_PRCHDESC_"^"_$PIECE(X,U,12)_"^"_PRCHFSC_"^"_NIIN_"^"_QTY_"^"_PRCHV_"^"
+3 SET TOTAL=$PIECE(X,U,6)
IF TOTAL["."
SET T1=$PIECE(TOTAL,".")
SET T2=$PIECE(TOTAL,".",2)_"00"
SET T2=$EXTRACT(T2,1,2)
SET TOTAL=T1_T2
GOTO RD3
+4 SET TOTAL=TOTAL_"00"
RD3 SET LCT=$PIECE(X,U,10)
IF LCT["."
SET LCT1=$PIECE(LCT,".")
SET LCT2=$PIECE(LCT,".",2)_"00"
SET LCT2=$EXTRACT(LCT2,1,2)
SET LCT=LCT1_LCT2
GOTO RD4
+1 SET LCT=LCT_"00"
RD4 SET HCT=$PIECE(X,U,11)
IF HCT["."
SET HCT1=$PIECE(HCT,".")
SET HCT2=$PIECE(HCT,".",2)_"00"
SET HCT2=$EXTRACT(HCT2,1,2)
SET HCT=HCT1_HCT2
GOTO RD5
+1 SET HCT=HCT_"00"
RD5 SET B=B_TOTAL_"^"_LCT_"^"_HCT_"^|"
SET COUNTER=COUNTER+1
SET ^TMP($JOB,"STRING",COUNTER)=B
QUIT
End DoDot:4
+1 QUIT
End DoDot:3
+2 QUIT
End DoDot:2
+3 QUIT
End DoDot:1
+4 SET X=^TMP($JOB,"STRING",1)
SET $PIECE(X,U,2)=PRCHSEG
SET ^TMP($JOB,"STRING",1)=X
+5 QUIT
+6 ;
EN2 ;SUMMARY TOTALS 'SU' SEGMENT OF '322' TRANSACTION
+1 NEW AOM,AOM1,AOM2,B,FRJD,OME,OME1,OME2,PRCHFSC,PRCHSEG,T1,T2,TOJD,TOTAL,X,Y
+2 if $$S^%ZTLOAD
QUIT
+3 SET X=FR
DO JD^PRCFDLN
SET FRJD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
SET X=TO
DO JD^PRCFDLN
SET TOJD=$EXTRACT(X,1,3)+1700_$EXTRACT(Y,1,3)
+4 SET PRCHFSC=""
SET PRCHSEG=0
FOR
SET PRCHFSC=$ORDER(^TMP($JOB,"FSC",PRCHFSC))
if 'PRCHFSC
QUIT
SET X=^TMP($JOB,"FSC",PRCHFSC)
Begin DoDot:1
+5 SET PRCHSEG=PRCHSEG+1
SET B="SU^"_PRCHSEG_"^"_FRJD_"^"_TOJD_"^"_PRCHFSC_"^"
+6 SET TOTAL=$PIECE(X,U,2)
IF TOTAL["."
SET T1=$PIECE(TOTAL,".")
SET T2=$PIECE(TOTAL,".",2)_"00"
SET T2=$EXTRACT(T2,1,2)
SET TOTAL=T1_T2
GOTO RDA
+7 SET TOTAL=TOTAL_"00"
RDA SET AOM=$PIECE(X,U,3)
IF AOM["."
SET AOM1=$PIECE(AOM,".")
SET AOM2=$PIECE(AOM,".",2)_"00"
SET AOM2=$EXTRACT(AOM2,1,2)
SET AOM=AOM1_AOM2
GOTO RDB
+1 SET AOM=AOM_"00"
RDB SET OME=$PIECE(X,U,4)
IF OME["."
SET OME1=$PIECE(OME,".")
SET OME2=$PIECE(OME,".",2)_"00"
SET OME2=$EXTRACT(OME2,1,2)
SET OME=OME1_OME2
GOTO RDC
+1 SET OME=OME_"00"
RDC SET B=B_TOTAL_"^"_AOM_"^"_OME_"^|"
SET COUNTER=COUNTER+1
SET ^TMP($JOB,"STRING",COUNTER)=B
QUIT
End DoDot:1
+1 SET X=^TMP($JOB,"STRING",1)
SET $PIECE(X,U,3)=PRCHSEG
SET ^TMP($JOB,"STRING",1)=X
+2 QUIT
+3 ;
EN3 ;END OF TRANSACTION LINE AND TRANSMISSION ROUTINE CALLS
+1 NEW %,%H,%I,CSDA,MO,PRCFASYS,TEST,YR,X
if $$S^%ZTLOAD
QUIT
+2 SET COUNTER=COUNTER+1
SET ^TMP($JOB,"STRING",COUNTER)="$"
+3 SET PRCFASYS="PRC"
SET PRCFA("TTF")="PRC"
DO NOW^%DTC
SET YR=$EXTRACT(X,2,3)
SET MO=$EXTRACT(X,4,5)
+4 SET PRC("FY")=$EXTRACT(100+$SELECT(MO>9:YR+1,1:YR),2,3)
+5 DO ^PRCFACX2
KILL ^TMP($JOB,"STRING")
SET CSDA=PRCFA("CSDA")
DO ^PRCFACB
if '$DATA(PRCF("BTCH"))
QUIT
SET TEST=PRCF("BTCH")
SET PRCFA("ISM")="XXX@Q-PRC.DOMAIN.EXT"
DO ^PRCFACBT
SET ZTREQ="@"
+6 IF $DATA(PRCOUT)
IF (PRCOUT>0)
SET ^TMP($JOB,"RESULTS")="NOMM"
QUIT
+7 SET ^TMP($JOB,"RESULTS")="OK^"_TEST_"^"_CSDA
KILL PRCOUT
+8 QUIT
