- PRCODCT ;WISC/DJM-DOCUMENT CONFIRMATION TRANSACTION SERVER ;6/19/96 11:03 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- IN ;THIS ROUTINE WILL BE CALLED FROM THE 'FMS' SERVER VIA THE FILE 423.5
- ;ENTRY FOR THE DOCUMENT CONFIRMATION TRANSACTION.
- ;PRCDA IS THE INTERNAL ENTRY NUMBER FOR THE RECORD FROM FILE 423.6.
- ;
- S:$D(^PRCTMP("BUGS","PRCH")) ^PRCTMP("PRCOSRV2",$J,"14",$H)="At PRCODCT, PRCDA = "_PRCDA_", ZTSK = "_ZTSK
- N AR,DCB,DCD,DCL,DOCID,LINE1,LN,RFLAG,SEGID,TRANS,PRCMG,PRCXM,LINE,STATION,STCK,ENTRY,ENCK,MGP,NAME,DIE,DR,DA,MTI,DOCLN,LNFLAG,DCL,PRCXM
- S LINE=$G(^PRCF(423.6,PRCDA,1,10000,0))
- S MGP=$O(^PRCF(423.5,"B",$P(LINE,U)_"-"_$P(LINE,U,5),0))
- S MGP=$G(^PRCF(423.5,MGP,0))
- I $P(MGP,U,2)]"" S PRCMG=$P($G(^XMB(3.8,$P(MGP,U,2),0)),U)
- D I $D(PRCXM(1)) D PERROR^PRCODCT1 Q
- .I $P(LINE,U,5)'="DCT" S PRCXM(1)=$P($T(ERROR+1),";;",2) Q
- .S STATION=$P(LINE,U,4) I STATION="" S PRCXM(1)=$P($T(ERROR+4),";;",2) Q
- .S STCK=$O(^PRC(411,"B",STATION,0)) I STCK'>0 S PRCXM(1)=$P($T(ERROR+2),";;",2) Q
- .Q
- ;
- FIND ;NOW THAT THE 'DCT' TRANSACTION BELONGS HERE LETS FIND THE FIRST
- ;'DOC' SEGMENT.
- ;
- K ^TMP($J,"GECSSDCT"),DCD,DCL
- S LINE=10000
- F S (DOCLN,LINE)=$O(^PRCF(423.6,PRCDA,1,LINE)) Q:LINE="" D Q:SEGID="DOC" Q:LINE1["{"
- .S LINE1=$G(^PRCF(423.6,PRCDA,1,LINE,0))
- .Q:LINE1="" Q:LINE1'["^"
- .Q:LINE1["{"
- .S SEGID=$P(LINE1,U) Q:SEGID=""
- .Q
- G:LINE1["{" EXIT
- ;
- ENTER ;OK, LETS ENTER IN EACH 'DCT' ENTRY BETWEEN TWO 'DOC's INTO THE FILE
- ;AS NEEDED.
- ;
- S LNFLAG=0 K PRCXM
- F S LINE=$O(^PRCF(423.6,PRCDA,1,LINE)) Q:LINE="" D Q:LINE1["{" I $D(PRCXM(1)) D PERROR^PRCODCT1 S LNFLAG=0
- .S LINE1=$G(^PRCF(423.6,PRCDA,1,LINE,0))
- .Q:LINE1=""
- .S SEGID=$P(LINE1,U)
- .Q:SEGID=""
- .Q:SEGID="ER1"
- .Q:SEGID="ER2"
- .I LNFLAG=0,SEGID'="DCD" S PRCXM(1)=$P($T(ERROR+6),";;",2) Q
- .I LNFLAG=0 S LNFLAG=1 D Q
- ..S ENTRY=$P(LINE1,U,6) I ENTRY="" S PRCXM(1)=$P($T(ERROR+3),";;",2) Q
- ..S TRANS=$E($P(LINE1,U,7)_" ",1,11) I $P(LINE1,U,7)="" S PRCXM(1)=$P($T(ERROR+5),";;",2) Q
- ..S DOCID=ENTRY_"-"_TRANS I $P(LINE1,U,8)]"",$P(LINE1,U,8)'="~" S DOCID=DOCID_"-"_$P(LINE1,U,8)
- ..S DCD=LINE_"^"_$P(LINE1,U,3)
- ..Q
- .I LNFLAG=1,'((SEGID="LIN")!(SEGID="DOC")!(SEGID="{")) S PRCXM(1)=$P($T(ERROR+7),";;",2) Q
- .I LNFLAG=1,SEGID="LIN" S LNFLAG=2 Q
- .I LNFLAG=1,((SEGID="DOC")!(SEGID="{")) S RFLAG=0 D D UPDATE S DOCLN=LINE,LNFLAG=0 K DOCID,DCD,DCL,RFLAG,AR Q
- ..I $D(DCD),$P(DCD,U,2)="R" S RFLAG=1 Q
- ..I $D(DCL) S LN="" F S LN=$O(DCL(LN)) Q:LN="" I $P(DCL(LN),U,2)="R" S RFLAG=1 Q
- ..Q
- .I LNFLAG=2,SEGID'="DCL" S PRCXM(1)=$P($T(ERROR+8),";;",2) Q
- .I LNFLAG=2,SEGID="DCL" S LNFLAG=3,LN=+$P(LINE1,U,5) S DCL(LN)=LINE_"^"_$P(LINE1,U,3) Q
- .I LNFLAG=3,'((SEGID="DOC")!(SEGID="LIN")!(SEGID="{")) S PRCXM(1)=$P($T(ERROR+9),";;",2) Q
- .I LNFLAG=3,SEGID="LIN" S LNFLAG=2 Q
- .I LNFLAG=3,((SEGID="DOC")!(SEGID="{")) S RFLAG=0 D D UPDATE S DOCLN=LINE,LNFLAG=0 K DOCID,DCD,DCL,RFLAG,AR Q
- ..I $D(DCD),$P(DCD,U,2)="R" S RFLAG=1 Q
- ..S LN="" F S LN=$O(DCL(LN)) Q:LN="" I $P(DCL(LN),U,2)="R" S RFLAG=1 Q
- ..Q
- .Q
- EXIT D KILL^PRCOSRV3(PRCDA)
- Q
- ;
- UPDATE S AR=$S(RFLAG=1:"R",1:"A") D PROCESS^GECSSDCT(DOCID,AR)
- I RFLAG=1 D PERROR^PRCODCT1
- I RFLAG'=1,"AR^SO^"[$E(DOCID,1,2)_"^" D
- . N DONE,LOOP,PRCMOP,PRCPO,PRCSIS,PRCTXN
- . S (DONE,LOOP)=0
- . S (PRCMOP,PRCPO,PRCSIS,PRCTXN)=""
- . D DATA^GECSSGET(DOCID,1) ; put info from 2100.1 into GECSDATA
- . I '$D(GECSDATA) Q ; don't process bad txns from FMS
- . S PRCPO=$P(GECSDATA(2100.1,GECSDATA,26,"E"),"/",1) ; 442 ien
- . S PRCMOP=$P(^PRC(442,PRCPO,0),"^",2) ; method of processing
- . ;
- . ; find the ien for this entry into file 2100.1
- . F S LOOP=$O(^PRC(442,PRCPO,10,LOOP)) Q:LOOP'>0!(DONE=1) D
- . . S NODE=^PRC(442,PRCPO,10,LOOP,0)
- . . I $P(NODE,"^",9)=GECSDATA D
- . . . I PRCMOP'=21 S PRCTXN=$P(NODE,"^",10),DONE=1
- . . . I PRCMOP=21 S PRCTXN=$P(NODE,"^",11),DONE=1
- . ;
- . ; label all appropriate txns for this adjust/amend # as final
- . I PRCTXN'="" D
- . .S PRCSIS=$$GETTXNS^PRCFFERT(PRCPO,PRCTXN,PRCMOP) ; find all 'sister' txns
- . . I $P(PRCSIS,"^",5)'=1,$P(PRCSIS,"^")="" D ;txn not part of a vendor, FCP, or PO# edit
- . . . F LOOP=2:1:4 I $P(PRCSIS,"^",LOOP)]"" D
- . . . . D DATA^GECSSGET($P(PRCSIS,"^",LOOP),1) ; get ien for each txn
- . . . . I $E($$STATUS^GECSSGET($P(PRCSIS,"^",LOOP)))'="A" D SETSTAT^GECSSTAA(GECSDATA,"F") ; update status for each sister txn to 'final'
- Q
- ;
- ERROR ;HERE IS THE LIST OF ERROR MESSAGES
- ;;This is not a Document Confirmation Transaction (DCT).
- ;;The STATION number sent from FMS can not be found at this location.
- ;;This FMS transaction has no FMS TRANSACTION CODE.
- ;;There is no STATION number sent from FMS.
- ;;There is no TRANSACTION NUMBER from FMS.
- ;;The DCD segment can't be found after a DOC segment.
- ;;The LIN segment can't be found after a DCL or a DCD segment.
- ;;The DCL segment can't be found after a LIN segment.
- ;;A LIN or a DOC segment can't be found after a DCL segment.
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCODCT 5042 printed Feb 18, 2025@23:38:02 Page 2
- PRCODCT ;WISC/DJM-DOCUMENT CONFIRMATION TRANSACTION SERVER ;6/19/96 11:03 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- IN ;THIS ROUTINE WILL BE CALLED FROM THE 'FMS' SERVER VIA THE FILE 423.5
- +1 ;ENTRY FOR THE DOCUMENT CONFIRMATION TRANSACTION.
- +2 ;PRCDA IS THE INTERNAL ENTRY NUMBER FOR THE RECORD FROM FILE 423.6.
- +3 ;
- +4 if $DATA(^PRCTMP("BUGS","PRCH"))
- SET ^PRCTMP("PRCOSRV2",$JOB,"14",$HOROLOG)="At PRCODCT, PRCDA = "_PRCDA_", ZTSK = "_ZTSK
- +5 NEW AR,DCB,DCD,DCL,DOCID,LINE1,LN,RFLAG,SEGID,TRANS,PRCMG,PRCXM,LINE,STATION,STCK,ENTRY,ENCK,MGP,NAME,DIE,DR,DA,MTI,DOCLN,LNFLAG,DCL,PRCXM
- +6 SET LINE=$GET(^PRCF(423.6,PRCDA,1,10000,0))
- +7 SET MGP=$ORDER(^PRCF(423.5,"B",$PIECE(LINE,U)_"-"_$PIECE(LINE,U,5),0))
- +8 SET MGP=$GET(^PRCF(423.5,MGP,0))
- +9 IF $PIECE(MGP,U,2)]""
- SET PRCMG=$PIECE($GET(^XMB(3.8,$PIECE(MGP,U,2),0)),U)
- +10 Begin DoDot:1
- +11 IF $PIECE(LINE,U,5)'="DCT"
- SET PRCXM(1)=$PIECE($TEXT(ERROR+1),";;",2)
- QUIT
- +12 SET STATION=$PIECE(LINE,U,4)
- IF STATION=""
- SET PRCXM(1)=$PIECE($TEXT(ERROR+4),";;",2)
- QUIT
- +13 SET STCK=$ORDER(^PRC(411,"B",STATION,0))
- IF STCK'>0
- SET PRCXM(1)=$PIECE($TEXT(ERROR+2),";;",2)
- QUIT
- +14 QUIT
- End DoDot:1
- IF $DATA(PRCXM(1))
- DO PERROR^PRCODCT1
- QUIT
- +15 ;
- FIND ;NOW THAT THE 'DCT' TRANSACTION BELONGS HERE LETS FIND THE FIRST
- +1 ;'DOC' SEGMENT.
- +2 ;
- +3 KILL ^TMP($JOB,"GECSSDCT"),DCD,DCL
- +4 SET LINE=10000
- +5 FOR
- SET (DOCLN,LINE)=$ORDER(^PRCF(423.6,PRCDA,1,LINE))
- if LINE=""
- QUIT
- Begin DoDot:1
- +6 SET LINE1=$GET(^PRCF(423.6,PRCDA,1,LINE,0))
- +7 if LINE1=""
- QUIT
- if LINE1'["^"
- QUIT
- +8 if LINE1["{"
- QUIT
- +9 SET SEGID=$PIECE(LINE1,U)
- if SEGID=""
- QUIT
- +10 QUIT
- End DoDot:1
- if SEGID="DOC"
- QUIT
- if LINE1["{"
- QUIT
- +11 if LINE1["{"
- GOTO EXIT
- +12 ;
- ENTER ;OK, LETS ENTER IN EACH 'DCT' ENTRY BETWEEN TWO 'DOC's INTO THE FILE
- +1 ;AS NEEDED.
- +2 ;
- +3 SET LNFLAG=0
- KILL PRCXM
- +4 FOR
- SET LINE=$ORDER(^PRCF(423.6,PRCDA,1,LINE))
- if LINE=""
- QUIT
- Begin DoDot:1
- +5 SET LINE1=$GET(^PRCF(423.6,PRCDA,1,LINE,0))
- +6 if LINE1=""
- QUIT
- +7 SET SEGID=$PIECE(LINE1,U)
- +8 if SEGID=""
- QUIT
- +9 if SEGID="ER1"
- QUIT
- +10 if SEGID="ER2"
- QUIT
- +11 IF LNFLAG=0
- IF SEGID'="DCD"
- SET PRCXM(1)=$PIECE($TEXT(ERROR+6),";;",2)
- QUIT
- +12 IF LNFLAG=0
- SET LNFLAG=1
- Begin DoDot:2
- +13 SET ENTRY=$PIECE(LINE1,U,6)
- IF ENTRY=""
- SET PRCXM(1)=$PIECE($TEXT(ERROR+3),";;",2)
- QUIT
- +14 SET TRANS=$EXTRACT($PIECE(LINE1,U,7)_" ",1,11)
- IF $PIECE(LINE1,U,7)=""
- SET PRCXM(1)=$PIECE($TEXT(ERROR+5),";;",2)
- QUIT
- +15 SET DOCID=ENTRY_"-"_TRANS
- IF $PIECE(LINE1,U,8)]""
- IF $PIECE(LINE1,U,8)'="~"
- SET DOCID=DOCID_"-"_$PIECE(LINE1,U,8)
- +16 SET DCD=LINE_"^"_$PIECE(LINE1,U,3)
- +17 QUIT
- End DoDot:2
- QUIT
- +18 IF LNFLAG=1
- IF '((SEGID="LIN")!(SEGID="DOC")!(SEGID="{"))
- SET PRCXM(1)=$PIECE($TEXT(ERROR+7),";;",2)
- QUIT
- +19 IF LNFLAG=1
- IF SEGID="LIN"
- SET LNFLAG=2
- QUIT
- +20 IF LNFLAG=1
- IF ((SEGID="DOC")!(SEGID="{"))
- SET RFLAG=0
- Begin DoDot:2
- +21 IF $DATA(DCD)
- IF $PIECE(DCD,U,2)="R"
- SET RFLAG=1
- QUIT
- +22 IF $DATA(DCL)
- SET LN=""
- FOR
- SET LN=$ORDER(DCL(LN))
- if LN=""
- QUIT
- IF $PIECE(DCL(LN),U,2)="R"
- SET RFLAG=1
- QUIT
- +23 QUIT
- End DoDot:2
- DO UPDATE
- SET DOCLN=LINE
- SET LNFLAG=0
- KILL DOCID,DCD,DCL,RFLAG,AR
- QUIT
- +24 IF LNFLAG=2
- IF SEGID'="DCL"
- SET PRCXM(1)=$PIECE($TEXT(ERROR+8),";;",2)
- QUIT
- +25 IF LNFLAG=2
- IF SEGID="DCL"
- SET LNFLAG=3
- SET LN=+$PIECE(LINE1,U,5)
- SET DCL(LN)=LINE_"^"_$PIECE(LINE1,U,3)
- QUIT
- +26 IF LNFLAG=3
- IF '((SEGID="DOC")!(SEGID="LIN")!(SEGID="{"))
- SET PRCXM(1)=$PIECE($TEXT(ERROR+9),";;",2)
- QUIT
- +27 IF LNFLAG=3
- IF SEGID="LIN"
- SET LNFLAG=2
- QUIT
- +28 IF LNFLAG=3
- IF ((SEGID="DOC")!(SEGID="{"))
- SET RFLAG=0
- Begin DoDot:2
- +29 IF $DATA(DCD)
- IF $PIECE(DCD,U,2)="R"
- SET RFLAG=1
- QUIT
- +30 SET LN=""
- FOR
- SET LN=$ORDER(DCL(LN))
- if LN=""
- QUIT
- IF $PIECE(DCL(LN),U,2)="R"
- SET RFLAG=1
- QUIT
- +31 QUIT
- End DoDot:2
- DO UPDATE
- SET DOCLN=LINE
- SET LNFLAG=0
- KILL DOCID,DCD,DCL,RFLAG,AR
- QUIT
- +32 QUIT
- End DoDot:1
- if LINE1["{"
- QUIT
- IF $DATA(PRCXM(1))
- DO PERROR^PRCODCT1
- SET LNFLAG=0
- EXIT DO KILL^PRCOSRV3(PRCDA)
- +1 QUIT
- +2 ;
- UPDATE SET AR=$SELECT(RFLAG=1:"R",1:"A")
- DO PROCESS^GECSSDCT(DOCID,AR)
- +1 IF RFLAG=1
- DO PERROR^PRCODCT1
- +2 IF RFLAG'=1
- IF "AR^SO^"[$EXTRACT(DOCID,1,2)_"^"
- Begin DoDot:1
- +3 NEW DONE,LOOP,PRCMOP,PRCPO,PRCSIS,PRCTXN
- +4 SET (DONE,LOOP)=0
- +5 SET (PRCMOP,PRCPO,PRCSIS,PRCTXN)=""
- +6 ; put info from 2100.1 into GECSDATA
- DO DATA^GECSSGET(DOCID,1)
- +7 ; don't process bad txns from FMS
- IF '$DATA(GECSDATA)
- QUIT
- +8 ; 442 ien
- SET PRCPO=$PIECE(GECSDATA(2100.1,GECSDATA,26,"E"),"/",1)
- +9 ; method of processing
- SET PRCMOP=$PIECE(^PRC(442,PRCPO,0),"^",2)
- +10 ;
- +11 ; find the ien for this entry into file 2100.1
- +12 FOR
- SET LOOP=$ORDER(^PRC(442,PRCPO,10,LOOP))
- if LOOP'>0!(DONE=1)
- QUIT
- Begin DoDot:2
- +13 SET NODE=^PRC(442,PRCPO,10,LOOP,0)
- +14 IF $PIECE(NODE,"^",9)=GECSDATA
- Begin DoDot:3
- +15 IF PRCMOP'=21
- SET PRCTXN=$PIECE(NODE,"^",10)
- SET DONE=1
- +16 IF PRCMOP=21
- SET PRCTXN=$PIECE(NODE,"^",11)
- SET DONE=1
- End DoDot:3
- End DoDot:2
- +17 ;
- +18 ; label all appropriate txns for this adjust/amend # as final
- +19 IF PRCTXN'=""
- Begin DoDot:2
- +20 ; find all 'sister' txns
- SET PRCSIS=$$GETTXNS^PRCFFERT(PRCPO,PRCTXN,PRCMOP)
- +21 ;txn not part of a vendor, FCP, or PO# edit
- IF $PIECE(PRCSIS,"^",5)'=1
- IF $PIECE(PRCSIS,"^")=""
- Begin DoDot:3
- +22 FOR LOOP=2:1:4
- IF $PIECE(PRCSIS,"^",LOOP)]""
- Begin DoDot:4
- +23 ; get ien for each txn
- DO DATA^GECSSGET($PIECE(PRCSIS,"^",LOOP),1)
- +24 ; update status for each sister txn to 'final'
- IF $EXTRACT($$STATUS^GECSSGET($PIECE(PRCSIS,"^",LOOP)))'="A"
- DO SETSTAT^GECSSTAA(GECSDATA,"F")
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +25 QUIT
- +26 ;
- ERROR ;HERE IS THE LIST OF ERROR MESSAGES
- +1 ;;This is not a Document Confirmation Transaction (DCT).
- +2 ;;The STATION number sent from FMS can not be found at this location.
- +3 ;;This FMS transaction has no FMS TRANSACTION CODE.
- +4 ;;There is no STATION number sent from FMS.
- +5 ;;There is no TRANSACTION NUMBER from FMS.
- +6 ;;The DCD segment can't be found after a DOC segment.
- +7 ;;The LIN segment can't be found after a DCL or a DCD segment.
- +8 ;;The DCL segment can't be found after a LIN segment.
- +9 ;;A LIN or a DOC segment can't be found after a DCL segment.