- PRCOPHA1 ;WISC/DJM-IFCAP EDI PHA RE-TRANSMIT ROUTINE ; [8/11/98 9:42am]
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- NEW(VAR1,VAR2) S PRCOPODA=VAR1
- N A,A1,A12,CSDA,MO,PRC,PRCFA,PRCFASYS,PTSW,RECORD,REQUEST,SERVICE,TEST,TOTAL,VEN,V1,V2,V3,V4,V5,YR,XMZ
- S A=$G(^PRC(442,VAR1,0)) S:A="" VAR2="NPO0" Q:A="" S PRC("SITE")=$P($P(A,U),"-"),YR=$E(DT,2,3),MO=$E(DT,4,5)
- S PRC("FY")=$E(100+$S(+MO>9:YR+1,1:YR),2,3)
- S SERVICE=$P(A,U,12) I SERVICE>0 S RECORD=$G(^PRC(442,VAR1,13,SERVICE,0)) I RECORD]"" S REQUEST=$P(RECORD,U,9) Q:REQUEST=3
- S A1=$G(^PRC(442,VAR1,1)) S:A1="" VAR2="NPO1" Q:A1="" Q:$P(A1,U,7)=1
- K ^TMP($J,"STRING") S VAR2="",A12=$G(^PRC(442,VAR1,12)) I A12]"" G:$P(A12,U,10)>0 EXIT
- S $P(A12,U,10)=999999999,^PRC(442,VAR1,12)=A12
- D HE^PRCOE3(VAR1,.VAR2) G:VAR2]"" EXIT
- D BI^PRCOE1(A,VAR1,.VAR2) G:VAR2]"" EXIT
- D VE^PRCOE1(A1,.VAR2) G:VAR2]"" EXIT
- D ST^PRCOE1(A,A1,VAR1,.VAR2) G:VAR2]"" EXIT
- D MI^PRCOE3(VAR1,.VAR2) G:VAR2]"" EXIT
- D AC^PRCOE4(A,A1,VAR1,.VAR2) G:VAR2]"" EXIT
- S TOTAL="" D IT^PRCOE2(VAR1,.VAR2,.TOTAL) G:VAR2]"" EXIT
- D CO^PRCOE3(VAR1,.VAR2,.TOTAL) G:VAR2]"" EXIT
- S IEN=$S($P($G(^PRC(442,VAR1,23)),U,7):$P(^(23),U,7),1:PRC("SITE"))
- S PTSW=$P($G(^PRC(411,IEN,9)),U,4)
- S V1=PRC("SITE"),V2="PHA",V3=$P($P(A,U),"-")_$P($P(A,U),"-",2),V4=$S(PTSW="T":"EDT",1:"EDP"),V5=200
- D TRANSMIT^PRCPSMCS(V1,V2,V3,V4,V5,1) S XMZ=$O(PRCPXMZ(0)) I XMZ>0 S $P(^PRC(442,VAR1,12),U,10)=PRCPXMZ(XMZ)
- S VAR2="OK ^ MAIL MESSAGE NO. = "_PRCPXMZ(XMZ)
- ;
- ; NOW LETS UPDATE THE ENTRY IN FILE 443.75.
- ;
- S V1=$P(A,U)
- S V2="PHA"
- S V3=PRCPXMZ(XMZ)
- S V4=$P($G(^PRC(440,$P(A1,U),3)),U,3)
- S V5=$P(A1,U,10)
- S V6=VAR1
- D ENTER^PRCOEDI(V1,V2,V3,V4,V5,V6)
- ;
- EXIT K ^TMP($J,"STRING") Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOPHA1 1776 printed Apr 23, 2025@18:26:34 Page 2
- PRCOPHA1 ;WISC/DJM-IFCAP EDI PHA RE-TRANSMIT ROUTINE ; [8/11/98 9:42am]
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- NEW(VAR1,VAR2) SET PRCOPODA=VAR1
- +1 NEW A,A1,A12,CSDA,MO,PRC,PRCFA,PRCFASYS,PTSW,RECORD,REQUEST,SERVICE,TEST,TOTAL,VEN,V1,V2,V3,V4,V5,YR,XMZ
- +2 SET A=$GET(^PRC(442,VAR1,0))
- if A=""
- SET VAR2="NPO0"
- if A=""
- QUIT
- SET PRC("SITE")=$PIECE($PIECE(A,U),"-")
- SET YR=$EXTRACT(DT,2,3)
- SET MO=$EXTRACT(DT,4,5)
- +3 SET PRC("FY")=$EXTRACT(100+$SELECT(+MO>9:YR+1,1:YR),2,3)
- +4 SET SERVICE=$PIECE(A,U,12)
- IF SERVICE>0
- SET RECORD=$GET(^PRC(442,VAR1,13,SERVICE,0))
- IF RECORD]""
- SET REQUEST=$PIECE(RECORD,U,9)
- if REQUEST=3
- QUIT
- +5 SET A1=$GET(^PRC(442,VAR1,1))
- if A1=""
- SET VAR2="NPO1"
- if A1=""
- QUIT
- if $PIECE(A1,U,7)=1
- QUIT
- +6 KILL ^TMP($JOB,"STRING")
- SET VAR2=""
- SET A12=$GET(^PRC(442,VAR1,12))
- IF A12]""
- if $PIECE(A12,U,10)>0
- GOTO EXIT
- +7 SET $PIECE(A12,U,10)=999999999
- SET ^PRC(442,VAR1,12)=A12
- +8 DO HE^PRCOE3(VAR1,.VAR2)
- if VAR2]""
- GOTO EXIT
- +9 DO BI^PRCOE1(A,VAR1,.VAR2)
- if VAR2]""
- GOTO EXIT
- +10 DO VE^PRCOE1(A1,.VAR2)
- if VAR2]""
- GOTO EXIT
- +11 DO ST^PRCOE1(A,A1,VAR1,.VAR2)
- if VAR2]""
- GOTO EXIT
- +12 DO MI^PRCOE3(VAR1,.VAR2)
- if VAR2]""
- GOTO EXIT
- +13 DO AC^PRCOE4(A,A1,VAR1,.VAR2)
- if VAR2]""
- GOTO EXIT
- +14 SET TOTAL=""
- DO IT^PRCOE2(VAR1,.VAR2,.TOTAL)
- if VAR2]""
- GOTO EXIT
- +15 DO CO^PRCOE3(VAR1,.VAR2,.TOTAL)
- if VAR2]""
- GOTO EXIT
- +16 SET IEN=$SELECT($PIECE($GET(^PRC(442,VAR1,23)),U,7):$PIECE(^(23),U,7),1:PRC("SITE"))
- +17 SET PTSW=$PIECE($GET(^PRC(411,IEN,9)),U,4)
- +18 SET V1=PRC("SITE")
- SET V2="PHA"
- SET V3=$PIECE($PIECE(A,U),"-")_$PIECE($PIECE(A,U),"-",2)
- SET V4=$SELECT(PTSW="T":"EDT",1:"EDP")
- SET V5=200
- +19 DO TRANSMIT^PRCPSMCS(V1,V2,V3,V4,V5,1)
- SET XMZ=$ORDER(PRCPXMZ(0))
- IF XMZ>0
- SET $PIECE(^PRC(442,VAR1,12),U,10)=PRCPXMZ(XMZ)
- +20 SET VAR2="OK ^ MAIL MESSAGE NO. = "_PRCPXMZ(XMZ)
- +21 ;
- +22 ; NOW LETS UPDATE THE ENTRY IN FILE 443.75.
- +23 ;
- +24 SET V1=$PIECE(A,U)
- +25 SET V2="PHA"
- +26 SET V3=PRCPXMZ(XMZ)
- +27 SET V4=$PIECE($GET(^PRC(440,$PIECE(A1,U),3)),U,3)
- +28 SET V5=$PIECE(A1,U,10)
- +29 SET V6=VAR1
- +30 DO ENTER^PRCOEDI(V1,V2,V3,V4,V5,V6)
- +31 ;
- EXIT KILL ^TMP($JOB,"STRING")
- QUIT
