Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCODCT

PRCODCT.m

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