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 Nov 22, 2024@17:21:45 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.
