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

PRCFFERT.m

Go to the documentation of this file. 
  1. PRCFFERT ;WISC/SJG-OBLIGATION ERROR PROCESSING REBUILD/RETRANSMIT ;7/24/00  23:20
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. TYPE(X) N FMSNO,STATUS
  1.  S PRC("SITE")=$P(X,U)
  1.  I ("^AR^MO^SO^"'[("^"_$P(X,U,2)_"^")) D MSG1^PRCFFERM,OUT Q
  1.  S STATUS=$G(GECSDATA(2100.1,GECSDATA,3,"E"))
  1.  D MSG^PRCFFER2($E(STATUS,1),.PRCFA) ; display transaction status info
  1.  D NUM^PRCFFERU ; put external PO# from GECSDATA into PONUM
  1.  D GET^PRCFFERU(442,PONUM) ; DIC call
  1.  I Y<0 D MSG2^PRCFFERM Q
  1.  S PO=Y,PO(0)=Y(0),PO(0,0)=Y(0,0)
  1.  S POIEN=+Y
  1.  K MOP S MOP=$P(Y(0),U,2) I MOP="" D MSG3^PRCFFERM Q
  1.  D GECS ; save selected txn's type & action in PRCFA("GECS")
  1.  I ("^1^2^3^4^7^8^26^"[("^"_MOP_"^")) I PRCFA("ERROR") D TPO
  1.  I MOP=21 I PRCFA("ERROR") D T1358
  1.  D OUT
  1.  D SCREEN
  1.  QUIT
  1.  ;
  1. TPO ; Purchase Order Error Processing when MOP = Invoice/Rec Rep,CI,Req
  1.  I $D(PRCFA("ERTYP")),PRCFA("ERTYP")'="POREQ" W !! D MSG5^PRCFFERM H 3 Q
  1.  S D0=+Y D STATR1^PRCFFERU(2)
  1.  S X=$P($G(RESP),U) I X D ^PRCHDP1
  1.  W ! S RETRAN=$$RETRANS^PRCFFERU(.RETRAN)
  1.  S X=$P($G(RETRAN),U) I 'X D MSG4^PRCFFERM H 3 Q
  1. TPO1 D
  1.  .S PRCFA("RETRAN")=1
  1.  .S PRCFA("PODA")=+PO,PCP=$P(PO(0),U,3)
  1.  .S $P(PCP,U,2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),U,12),1:"")
  1.  .I '$D(PRC("FY")) D
  1.  ..N FYQ S FYQ=$$FYQ^PRCFFERU(.FYQ)
  1.  ..S PRC("FY")=$P(FYQ,U),PRC("QTR")=$P(FYQ,U,2)
  1.  ..Q
  1.  .I '$D(PRC("PARAM")) S PRC("PARAM")=$$NODE^PRC0B("^PRC(411,PRC(""SITE""),",0)
  1.  .N PRCRGS,MODDOC S FLG=0
  1.  .S MODDOC=$P($G(PRCFA("GECS")),"^",3)
  1.  .S PRCRGS=$S(MODDOC="":1,MODDOC]"":2)
  1.  .I MODDOC="" D RETRAN^PRCFFMO Q
  1.  .I MODDOC]"" D  Q
  1.  ..N RBLD S RBLD=$G(GECSDATA(2100.1,GECSDATA,26,"E"))
  1.  ..I RBLD]"" S (PRCFA("AMEND#"),PRCFAA)=$P(RBLD,"/",2),PRCFPODA=+PO
  1.  ..I RBLD="" D
  1.  ...S (PRCFA("AMEND#"),X)=0
  1.  ...F  S X=$O(^PRC(442,+PO,6,X)) Q:X'>0  S PRCFAA=X
  1.  ...S PRCFA("AMEND#")=PRCFAA,PRCFPODA=+PO
  1.  ...Q
  1.  ..D SETAM,RETRAN^PRCFFMOM
  1.  ..Q
  1.  .Q
  1.  Q
  1. SETPO ;
  1.  S FMSSEC=$$SEC1^PRC0C(PRC("SITE"))
  1.  S DESC="Purchase Order Obligation Rebuild/Transmit"
  1.  S:MODDOC]"" DESC="Purchase Order Amendment Rebuild/Transmit"
  1.  D REBUILD^GECSUFM1(GECSDATA,"I",FMSSEC,"Y",DESC)
  1.  S GECSFMS("DA")=GECSDATA
  1.  Q
  1. SETAM ;
  1.  N DIC S DIC="^PRC(442,"_+PO_",6,",DIC(0)="MNZ",X=PRCFA("AMEND#")
  1.  D ^DIC I +Y>0 S PO(6)=Y(0),PO(6,1)=^PRC(442,+PO,6,PRCFA("AMEND#"),1)
  1.  Q
  1. T1358 ; 1358 Error Processing when MOP = MISC OBL(1358)
  1.  I $D(PRCFA("ERTYP")),PRCFA("ERTYP")'="MISCOBL" W !! D MSG5^PRCFFERM H 3 Q
  1.  D STATR1^PRCFFERU(2)
  1.  D GENDIQ^PRCFFU7(442,+POIEN,".07","I","")
  1.  S (OB,DA)=$G(PRCTMP(442,+POIEN,".07","I"))
  1.  D NODE^PRCS58OB(DA,.TRNODE)
  1.  I '$D(PRC("CP")) S PRC("CP")=$P(TRNODE(0),"-",4)
  1.  S X=$P($G(RESP),U) I X D
  1.  .D PAUSE1^PRCFFERU
  1.  .S IOP="HOME" D ^%ZIS,^PRCE58P0
  1.  .Q
  1.  W ! S RETRAN=$$RETRANS^PRCFFERU(.RETRAN)
  1.  S X=$P($G(RETRAN),U) I 'X D MSG4^PRCFFERM H 3 Q
  1. T13581 D
  1.  .S PRCFA("RETRAN")=1,DA=OB
  1.  .I '$D(PRC("FY")) D
  1.  ..N FYQ S FYQ=$$FYQ^PRCFFERU(.FYQ)
  1.  ..S PRC("FY")=$P(FYQ,U),PRC("QTR")=$P(FYQ,U,3)
  1.  ..Q
  1.  .I '$D(PRC("PARAM")) S PRC("PARAM")=$$NODE^PRC0B("^PRC(411,PRC(""SITE""),",0)
  1.  .N PRCRGS,MODDOC
  1.  .S MODDOC=$P($G(PRCFA("GECS")),"^",3)
  1.  .S PRCRGS=$S(MODDOC="":1,MODDOC]"":2)
  1.  .I MODDOC="" D SC^PRCESOE Q
  1.  .I MODDOC]"" D  Q
  1.  ..N RBLD S RBLD=$G(GECSDATA(2100.1,GECSDATA,26,"E"))
  1.  ..I RBLD]"" S Y=$P(RBLD,"/",4)
  1.  ..I RBLD="" D
  1.  ...S PATNUM=$$STRIP^PRCFFERU(PATNUM)
  1.  ...S Y=$O(^PRCS(410,"D",PATNUM,0))
  1.  ...Q
  1.  ..W ! D RETRAN^PRCEADJ1 Q
  1.  Q
  1.  ;
  1. SET1358 S FMSSEC=$$SEC1^PRC0C(PRC("SITE"))
  1.  S DESC="1358 Obligation Rebuild/Transmit"
  1.  S:MODDOC]"" DESC="1358 Obligation Adjustment Rebuild/Transmit"
  1.  D REBUILD^GECSUFM1(GECSDATA,"I",FMSSEC,"Y",DESC)
  1.  S GECSFMS("DA")=GECSDATA
  1.  Q
  1.  ;
  1.  ; get current txn's type, action & amendment/adjustment #
  1. GECS N LOOP,NODE,X
  1.  S LOOP=0,PRCFA("GECS")=""
  1.  F  S LOOP=$O(^PRC(442,+PO,10,LOOP)) Q:LOOP'>0!($G(PRCFA("GECS"))'="")  D
  1.  . S NODE=^PRC(442,+PO,10,LOOP,0)
  1.  . I GECSDATA(2100.1,GECSDATA,.01,"E")=$P(NODE,"^",4) D
  1.  . . S PRCFA("GECS")=$E(NODE,1,2)_"^"_$E(NODE,4)_"^"_$P(NODE,"^",10)_"^"_$P(NODE,"^",9)
  1.  . . I MOP=21 S $P(PRCFA("GECS"),"^",3)=$P(NODE,"^",11) ; 1358s
  1.  Q
  1.  ;
  1.  ; find all FMS txn associated with the amendment/adjustment #
  1.  ; PO = purchase order ien
  1.  ; VER = amendment/adjustment #
  1.  ; MOP = method of processing
  1.  ; returns DOC IDs for SO, AR.E, AR.M codesheets on same amend/adjust#
  1. GETTXNS(PO,VER,MOP) N LOOP,NODE,PRCSOE,PRCSOM,PRCARE,PRCARM,PRCCAN,TYPE,X
  1.  S TYPE=10 I MOP=21 S TYPE=11 ; piece holding amend/adjust#
  1.  S LOOP=0,(PRCSOE,PRCSOM,PRCARE,PRCARM,PRCCAN)=""
  1.  F  S LOOP=$O(^PRC(442,+PO,10,LOOP)) Q:LOOP'>0  D
  1.  . S NODE=^PRC(442,+PO,10,LOOP,0)
  1.  . I $E(NODE,1,4)="SO.E",VER=$P(NODE,"^",TYPE) S PRCSOE=$P(NODE,"^",4)
  1.  . I $E(NODE,1,4)="SO.M",VER=$P(NODE,"^",TYPE) S PRCSOM=$P(NODE,"^",4)
  1.  . I $E(NODE,1,4)="AR.E",VER=$P(NODE,"^",TYPE) S PRCARE=$P(NODE,"^",4)
  1.  . I $E(NODE,1,4)="AR.M",VER=$P(NODE,"^",TYPE) S PRCARM=$P(NODE,"^",4)
  1.  . I $E(NODE,4)="X",VER=$P(NODE,"^",TYPE) S PRCCAN=1 ; canceled amend#
  1.  S X=PRCSOE_"^"_PRCSOM_"^"_PRCARE_"^"_PRCARM_"^"_PRCCAN
  1.  Q X
  1.  ;
  1.  ;
  1.  ; Compares transaction types passed to string of existing transactions
  1.  ;  returns .01 field of file 2100.1 if transaction type is in string
  1.  ;           zero, if types are not in string
  1.  ; 
  1.  ; TXNTP = Transaction Type
  1.  ; TXNAC = Transaction Action
  1.  ; STRING (Of 2100.1 doc id's) = SOE ^ SOM ^ ARE ^ ARM ^ flag for cancel
  1.  ; 
  1. NEWCHK(TXNTP,TXNAC,STRING) N DOCID
  1.  S DOCID=0
  1.  I $P(TXNTP,"^",5)'=1 D  ; amend# canceled
  1.  . I $P(TXNTP,":")="SO",TXNAC="E",$P(STRING,"^",1)]"" S DOCID=$P(STRING,"^",1)
  1.  . I $P(TXNTP,":")="SO",TXNAC="M",$P(STRING,"^",2)]"" S DOCID=$P(STRING,"^",2)
  1.  . I $P(TXNTP,":")="AR",TXNAC="E",$P(STRING,"^",3)]"" S DOCID=$P(STRING,"^",3)
  1.  . I $P(TXNTP,":")="AR",TXNAC="M",$P(STRING,"^",4)]"" S DOCID=$P(STRING,"^",4)
  1.  Q DOCID
  1.  ;
  1.  ; Check the selected transaction
  1.  ; if unavailable, give message & return '^'
  1.  ; if available, set up GECSDATA array and return 1
  1. SWITCH(DOCID,MP,GECSDATA) ;
  1.  N STATUS,X
  1.  D EN^DDIOL("Document exists for "_DOCID_".  Attempting to rebuild.")
  1.  D EN^DDIOL(" ")
  1.  S STATUS=$$STATUS^GECSSGET(DOCID)
  1.  I "RENT"'[$E(STATUS) D
  1.  . D EN^DDIOL("Unable to rebuild now -- document has status of "_STATUS_".")
  1.  . S X=$S($E(DOCID,1,2)="AR":"AR",MP=21:"SO",1:"MO/SO")
  1.  . D EN^DDIOL("Please rebuild "_DOCID_" later using the "_X_" option.")
  1.  . S X="^"
  1.  I "RENT"[$E(STATUS) D
  1.  . D DATA^GECSSGET(DOCID,0)
  1.  . D EN^DDIOL("Rebuild will continue using "_DOCID_".")
  1.  . S X=1
  1.  Q X
  1.  ;
  1. OUT K GECSDATA,FMSNO,STATUS,DIC,FMSSEC,DESC
  1.  Q
  1. SCREEN ; Control screen display
  1.  I $D(IOF) W @IOF
  1. HDR ; Write Option Header
  1.  I $D(XQY0) W IOINHI,$P(XQY0,U,2),IOINORM
  1.  Q