- 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 Mar 13, 2025@21:14:54 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
