PRCFDA2 ;WISC@ALTOONA/CTB/BGJ-PROCESS PAYMENT TO FMS ; 9/28/99 4:12pm
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN S PRCTXD=$P($G(^PRCF(421.5,PRCF("CIDA"),1)),U,19)
S DIE=421.5,DA=PRCF("CIDA")
S DR="71R//^S X=$$DATE^PRCFDA2(PRCF(""PODA""),PRC10DA);S PRCTXD=$E(X,1,5)*100;72////^S X=PRCTXD;S Y=""@1"";@1;72R//^S X=$$MONYR^PRCFDA2(PRCTXD)"
D ^DIE K DIE,DR,DA I $D(DTOUT)!$D(Y) G OT^PRCFDA
S PRCF("MOP")=$P($G(^PRC(442,PRCF("PODA"),0)),U,2)
S X=$P($P($G(^PRC(442,PRCF("PODA"),10,1,0)),U),".",1,2)
S PRCF("TC")=$P(X,".",1)
S PRCF("TC")=$S(PRCF("TC")?2U:PRCF("TC"),PRCF("MOP")=2:"SO",PRCF("MOP")=21:"SO",1:"MO")
I PRCF("TC")="SO" D
. N PRCFATT
. S PRCFATT=PRCF("TC")
. D SOAR^PRC0E(PRCF("PODA"),.PRCFATT,2) ; ask post against SO OR AR?
. S PRCF("TC")=PRCFATT
I "^AR^SO^MO"'[("^"_PRCF("TC")) G OT^PRCFDA
S X=$P($G(^PRCF(421.5,PRCF("CIDA"),1)),U,19,20),Y=$P(X,U,2),X=$P(X,U)
S:$G(DT)>X X=DT S DIR(0)="YA",DIR("B")="YES"
S DIR("A",1)="Your FMS document will be transmitted on "_$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_" and will affect the"
S DIR("A")="accounting period "_$$MONYR(Y)_". Is this okay? "
D ^DIR K DIR G OT^PRCFDA:$D(DIRUT),EN:Y<1
SIG D SIG^PRCFACX0 I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") G OT^PRCFDA
S DA=PRCF("CIDA"),MESSAGE=""
D REMOVE^PRCFDES2(DA),ENCODE^PRCFDES2(DA,DUZ,.MESSAGE)
K MESSAGE,DA
S ACTION="E" K ^TMP($J,"PRCPV")
;I $D(PRCFA("ERROR PROCESSING")) S ACTION="M"
S N1=$G(^PRCF(421.5,PRCF("CIDA"),1))
S PRCF("PO")=$P(N1,U,3),PRCF("PA")=$P(N1,U,6)
I PRCF("PA")="" D G:PRCF("PA")="" EX
NEXT . ; Obtain next available Partial# for the PO
. N K,DA S K=0,Y=$O(^PRCF(421.9,"B",PRCF("PO"),0))
. I Y="" S X=PRCF("PO"),DIC="^PRCF(421.9,",DLAYGO=421.9,DIC(0)="XL"
. I Y="" K DO,DINUM,DIC("DR") D FILE^DICN S %=0 K DIC,DLAYGO Q:Y<0
. S DA=Y
. S Y1=$P(^PRCF(421.9,+DA,0),"^",2)+1
. I Y1>949,Y1<974 S X="WARNING: This partial, number "_Y1_", is approaching the limit of 974 permitted by the system." W !! D MSG^PRCFQ W $C(7),$C(7),$C(7),$C(7)
. I Y1=974 S X="WARNING: This partial, number "_Y1_", is the last permitted by the system." W !! D MSG^PRCFQ W $C(7),$C(7),$C(7),$C(7)
. I Y1=974 S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO" D ^DIR I $D(DIRUT)!(Y=0) K DIR,Y1,DA Q
. I Y1>974 S X="WARNING: THIS PARTIAL, NUMBER "_Y1_", HAS EXCEEDED THE SYSTEM LIMIT OF 974. UNABLE TO PROCESS THIS TRANSACTION." D Q
. . S X=X_" IF NECESSARY, A PV DOCUMENT WILL HAVE TO BE CREATED ON-LINE IN FMS." W !! D MSG^PRCFQ W $C(7),$C(7),$C(7),$C(7) K Y1,DA
. L +^PRCF(421.9):5 I '$T S X="Partial Number file unavailable - File lock timeout.*" D MSG^PRCFQ K Y1,DA,DIR Q
. S Y(0)=^PRCF(421.9,+DA,0),Y1=$P(Y(0),"^",2)+1
. S $P(^PRCF(421.9,+DA,0),"^",2)=Y1
. L -^PRCF(421.9) D ALPHA^PRCFPAR(Y1,.X) S PRCF("PA")=X
. K Y(0),Y1,X,DA,DIR
. S $P(^PRCF(421.5,PRCF("CIDA"),1),U,6)=PRCF("PA")
. Q
;
S:PRCF("PA")?1N PRCF("PA")="0"_PRCF("PA")
S XPO=$P(PRCF("PO"),"-",1)_$P(PRCF("PO"),"-",2)_PRCF("PA")
S PRCF("TN")=$E(XPO,1,9)_$S(PRCF("TC")="AR":12,1:" ")
S X="Transferring invoice data to PV document for transmission to FMS.*"
W ! D MSG^PRCFQ,NEW^PRCFD8(PRCF("CIDA"),ACTION)
I '$D(PRCFA("ERROR PROCESSING")) D G:'$D(GECSFMS("DA")) EX
. I $G(^%ZOSF("TEST")) S X="GECSUFMS" X ^%ZOSF("TEST") I '$T S X="Generic Code Sheet routine GECSUFMS missing - cannot continue.*" D MSG^PRCFQ Q
. D CONTROL^GECSUFMS("I",+PRC("SITE"),XPO,"PV",$$SEC1^PRC0C(PRC("SITE")),0,"","Payment Voucher")
. I '$D(GECSFMS("DA")) S X="No new FMS Payment Voucher created - Files inaccessible at this time.*" D MSG^PRCFQ
. Q
I $D(PRCFA("ERROR PROCESSING")) S CODESHET=0 D G:'$D(GECSDATA) EX
. I $G(^%ZOSF("TEST")) S X="GECSSGET" X ^%ZOSF("TEST") I '$T S X="Generic Code Sheet routine GECSSGET missing - cannot continue.*" D MSG^PRCFQ Q
. S DOCID="PV-"_XPO D DATA^GECSSGET(DOCID,CODESHET)
. I '$D(GECSDATA) S X="FMS Payment Voucher not rebuilt or transmitted - could not locate original PV in local stack file.*" D MSG^PRCFQ Q
. S PRCFD("STACK")=GECSDATA
. I $G(^%ZOSF("TEST")) S X="GECSUFM1" X ^%ZOSF("TEST") I '$T S X="Generic Code Sheet routine GECSUFM1 missing - cannot continue.*" D MSG^PRCFQ K GECSDATA Q
. D REBUILD^GECSUFM1(GECSDATA,"I",$$SEC1^PRC0C(PRC("SITE")),"","Payment Voucher Retransmission")
. Q
I $D(GECSFMS("DA"))=0,+$G(PRCFD("STACK")) S GECSFMS("DA")=PRCFD("STACK")
I $G(^%ZOSF("TEST")) S X="GECSSTAA" X ^%ZOSF("TEST") I '$T S X="Generic Code Sheet routine GECSSTAA missing - cannot continue.*" D MSG^PRCFQ G EX
S IX=0 F S IX=$O(^TMP($J,"PRCPV",IX)) Q:'IX D SETCS^GECSSTAA(GECSFMS("DA"),^(IX))
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
S X="PV document is complete and is queued for transmission to FMS.*"
; Save GECS Stack File PV # in Invoice record:
S DIE=421.5,DA=PRCF("CIDA"),DR="27///^S X=XPO" D ^DIE K DA,DIE,DR
D MSG^PRCFQ S X=20 D STATUS^PRCFDE1
; Post FMS Document Information to Purchase Order:
S PRCFA("SYS")="FMS",PRCFA("PODA")=PRCF("PODA"),POESIG=1
S XA="PV",XB=0 S:ACTION="M" XB=1
S XC=$P($G(^PRCF(421.5,PRCF("CIDA"),1)),U,19) S:XC="" XC=$P(^PRCF(421.5,PRCF("CIDA"),0),U,5)
S XD=$P(PRCF("PO"),"-",2)
D EN7^PRCFFU41(XA,XB,XC,XD)
EX L:$D(PRCF("CIDA")) -^PRCF(421.5,PRCF("CIDA"))
K ACTION,N1,XPO,IX,XA,XB,XC,XD,DOCID,GECSDATA,GECSFMS,POESIG
K BOC,CNT,LAMT,D0,LD,FMSTYPE,GO,LABEL,LOOP
K RECORD,RECORD1,RESP,RETRAN,STATUS,TXT,VAR,PRCFX,MOP,PO,PONUM,PRC
K PRCF,PRCFD,PRC10DA,PRCTXD,X,Y,FMSLN,IEN,DIC
K PRCTMP,PATDA,CODESHET
K ^TMP($J,"PRCPV")
I $D(PRCFA("ERROR PROCESSING")),PRCFA("ERROR PROCESSING")'=2 K PRCFA Q
K PRCFA
I $D(DUOUT)!$D(DTOUT)!$D(DIRUT)!$D(DIROUT) K DUOUT,DTOUT,DIRUT,DIROUT Q
G ^PRCFDA
;
DATE(A,B) ;Returns in external format, the greater of Today and the
;original obligation date
N X,Y S X=$P($P($G(^PRC(442,A,10,B,0)),U),".",3)
S:X'="" X=$S(+$E(X,5,6)<80:3,1:2)_$E(X,5,6)_$E(X,1,2)_$E(X,3,4)
S:$P($G(DT),".")>X X=$P(DT,".")
S Y=$P("JAN~FEB~MAR~APR~MAY~JUN~JUL~AUG~SEP~OCT~NOV~DEC","~",+$E(X,4,5))
S Y=Y_" "_+$E(X,6,7)_", "_(1700+$E(X,1,3))
Q Y
MONYR(X) ;Returns External Month and Day from FileMan Date
N Y
I X'?7N.E S Y="" Q Y
S Y=$P("JAN~FEB~MAR~APR~MAY~JUN~JUL~AUG~SEP~OCT~NOV~DEC","~",+$E(X,4,5))
S Y=Y_" "_(1700+$E(X,1,3))
Q Y
ASK ; If there are more than one BOC on the obligation ask the user for
; the BOC to be processed.
S DIR(0)="NO"
N PRCFBOC S PRCFBOC=""
S DIR("A")="Select FMS LINE BOC: "
S DIR("B")=$O(PRCFX("SA",PRCFBOC))
S DIR("?")="^D HELP^PRCFDA2"
S DIR("??")="^W !!?15,""You may only enter a BOC from Obligation ""_PRCF(""CIDA"")"
D ^DIR I $D(DIRUT) S PRCFEX=1 Q
I '$D(DIRUT) S PRCFFLG=1
I '$D(PRCFX("SA",X)) K X W "??" G BOC^PRCFDA
S BOC=Y
ASK2 ;checks to see if there are >1 FMS lines on a particular BOC
;also an entry pointfor when there is only 1 BOC to check to
;if there are >1 FMS line on that BOC
N CNT2,PRCFEE,PRCNOBOC S CNT2=""
S PRCFNUM="" F S PRCFNUM=$O(PRCFX("SA",BOC,PRCFNUM)) Q:'PRCFNUM S CNT2=CNT2+1
I CNT2>1 D I $G(PRCNOBOC)=1 G BOC^PRCFDA
. W !!,"Choose from: "
. S PRCFEE="" F S PRCFEE=$O(PRCFX("SA",BOC,PRCFEE)) Q:'PRCFEE W !?5,PRCFEE_" "_BOC_" "_$S($P($G(PRCFX("SA",BOC,PRCFEE)),U,2)=991:"Shipping",1:"Goods/Services")
. S DIR(0)="NOA"
. S DIR("A")="Enter the number of your choice: "
. S DIR("T")=30
. D ^DIR I $D(DIRUT) S PRCFEXIT=1 Q
. I '$D(DIRUT) S PRCFFLG=1
. I '$D(PRCFX("SA",BOC,X)) K X W "??" S PRCNOBOC=1
. S PRCFNUM=Y
. Q
I CNT2=1 S PRCFNUM=0 S PRCFNUM=$O(PRCFX("SA",BOC,PRCFNUM)) I $G(CNT1)=1 S PRCFFLG=2
Q
HELP ;Help for BOC look-up
N NUM,NUM2
W ?5,"Answer with a BOC from this Obligation.",!
S NUM=""
S NUM=$O(PRCFX("SA",NUM)) Q:'NUM D
. I $O(PRCFX("SA",NUM))]"" W !?10,"Choose from: " Q
S (NUM,NUM2)=""
F S NUM=$O(PRCFX("SA",NUM)) Q:'NUM D
. F S NUM2=$O(PRCFX("SA",NUM,NUM2)) Q:'NUM2 D
. . W !?15,NUM," ",$S($P(PRCFX("SA",NUM,NUM2),U,2)=991:"Shipping",1:"Goods/Services")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDA2 8005 printed Oct 16, 2024@18:03:33 Page 2
PRCFDA2 ;WISC@ALTOONA/CTB/BGJ-PROCESS PAYMENT TO FMS ; 9/28/99 4:12pm
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN SET PRCTXD=$PIECE($GET(^PRCF(421.5,PRCF("CIDA"),1)),U,19)
+1 SET DIE=421.5
SET DA=PRCF("CIDA")
+2 SET DR="71R//^S X=$$DATE^PRCFDA2(PRCF(""PODA""),PRC10DA);S PRCTXD=$E(X,1,5)*100;72////^S X=PRCTXD;S Y=""@1"";@1;72R//^S X=$$MONYR^PRCFDA2(PRCTXD)"
+3 DO ^DIE
KILL DIE,DR,DA
IF $DATA(DTOUT)!$DATA(Y)
GOTO OT^PRCFDA
+4 SET PRCF("MOP")=$PIECE($GET(^PRC(442,PRCF("PODA"),0)),U,2)
+5 SET X=$PIECE($PIECE($GET(^PRC(442,PRCF("PODA"),10,1,0)),U),".",1,2)
+6 SET PRCF("TC")=$PIECE(X,".",1)
+7 SET PRCF("TC")=$SELECT(PRCF("TC")?2U:PRCF("TC"),PRCF("MOP")=2:"SO",PRCF("MOP")=21:"SO",1:"MO")
+8 IF PRCF("TC")="SO"
Begin DoDot:1
+9 NEW PRCFATT
+10 SET PRCFATT=PRCF("TC")
+11 ; ask post against SO OR AR?
DO SOAR^PRC0E(PRCF("PODA"),.PRCFATT,2)
+12 SET PRCF("TC")=PRCFATT
End DoDot:1
+13 IF "^AR^SO^MO"'[("^"_PRCF("TC"))
GOTO OT^PRCFDA
+14 SET X=$PIECE($GET(^PRCF(421.5,PRCF("CIDA"),1)),U,19,20)
SET Y=$PIECE(X,U,2)
SET X=$PIECE(X,U)
+15 if $GET(DT)>X
SET X=DT
SET DIR(0)="YA"
SET DIR("B")="YES"
+16 SET DIR("A",1)="Your FMS document will be transmitted on "_$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_" and will affect the"
+17 SET DIR("A")="accounting period "_$$MONYR(Y)_". Is this okay? "
+18 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO OT^PRCFDA
if Y<1
GOTO EN
SIG DO SIG^PRCFACX0
IF $DATA(PRCFA("SIGFAIL"))
KILL PRCFA("SIGFAIL")
GOTO OT^PRCFDA
+1 SET DA=PRCF("CIDA")
SET MESSAGE=""
+2 DO REMOVE^PRCFDES2(DA)
DO ENCODE^PRCFDES2(DA,DUZ,.MESSAGE)
+3 KILL MESSAGE,DA
+4 SET ACTION="E"
KILL ^TMP($JOB,"PRCPV")
+5 ;I $D(PRCFA("ERROR PROCESSING")) S ACTION="M"
+6 SET N1=$GET(^PRCF(421.5,PRCF("CIDA"),1))
+7 SET PRCF("PO")=$PIECE(N1,U,3)
SET PRCF("PA")=$PIECE(N1,U,6)
+8 IF PRCF("PA")=""
Begin DoDot:1
NEXT ; Obtain next available Partial# for the PO
+1 NEW K,DA
SET K=0
SET Y=$ORDER(^PRCF(421.9,"B",PRCF("PO"),0))
+2 IF Y=""
SET X=PRCF("PO")
SET DIC="^PRCF(421.9,"
SET DLAYGO=421.9
SET DIC(0)="XL"
+3 IF Y=""
KILL DO,DINUM,DIC("DR")
DO FILE^DICN
SET %=0
KILL DIC,DLAYGO
if Y<0
QUIT
+4 SET DA=Y
+5 SET Y1=$PIECE(^PRCF(421.9,+DA,0),"^",2)+1
+6 IF Y1>949
IF Y1<974
SET X="WARNING: This partial, number "_Y1_", is approaching the limit of 974 permitted by the system."
WRITE !!
DO MSG^PRCFQ
WRITE $CHAR(7),$CHAR(7),$CHAR(7),$CHAR(7)
+7 IF Y1=974
SET X="WARNING: This partial, number "_Y1_", is the last permitted by the system."
WRITE !!
DO MSG^PRCFQ
WRITE $CHAR(7),$CHAR(7),$CHAR(7),$CHAR(7)
+8 IF Y1=974
SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue"
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DIRUT)!(Y=0)
KILL DIR,Y1,DA
QUIT
+9 IF Y1>974
SET X="WARNING: THIS PARTIAL, NUMBER "_Y1_", HAS EXCEEDED THE SYSTEM LIMIT OF 974. UNABLE TO PROCESS THIS TRANSACTION."
Begin DoDot:2
+10 SET X=X_" IF NECESSARY, A PV DOCUMENT WILL HAVE TO BE CREATED ON-LINE IN FMS."
WRITE !!
DO MSG^PRCFQ
WRITE $CHAR(7),$CHAR(7),$CHAR(7),$CHAR(7)
KILL Y1,DA
End DoDot:2
QUIT
+11 LOCK +^PRCF(421.9):5
IF '$TEST
SET X="Partial Number file unavailable - File lock timeout.*"
DO MSG^PRCFQ
KILL Y1,DA,DIR
QUIT
+12 SET Y(0)=^PRCF(421.9,+DA,0)
SET Y1=$PIECE(Y(0),"^",2)+1
+13 SET $PIECE(^PRCF(421.9,+DA,0),"^",2)=Y1
+14 LOCK -^PRCF(421.9)
DO ALPHA^PRCFPAR(Y1,.X)
SET PRCF("PA")=X
+15 KILL Y(0),Y1,X,DA,DIR
+16 SET $PIECE(^PRCF(421.5,PRCF("CIDA"),1),U,6)=PRCF("PA")
+17 QUIT
End DoDot:1
if PRCF("PA")=""
GOTO EX
+18 ;
+19 if PRCF("PA")?1N
SET PRCF("PA")="0"_PRCF("PA")
+20 SET XPO=$PIECE(PRCF("PO"),"-",1)_$PIECE(PRCF("PO"),"-",2)_PRCF("PA")
+21 SET PRCF("TN")=$EXTRACT(XPO,1,9)_$SELECT(PRCF("TC")="AR":12,1:" ")
+22 SET X="Transferring invoice data to PV document for transmission to FMS.*"
+23 WRITE !
DO MSG^PRCFQ
DO NEW^PRCFD8(PRCF("CIDA"),ACTION)
+24 IF '$DATA(PRCFA("ERROR PROCESSING"))
Begin DoDot:1
+25 IF $GET(^%ZOSF("TEST"))
SET X="GECSUFMS"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET X="Generic Code Sheet routine GECSUFMS missing - cannot continue.*"
DO MSG^PRCFQ
QUIT
+26 DO CONTROL^GECSUFMS("I",+PRC("SITE"),XPO,"PV",$$SEC1^PRC0C(PRC("SITE")),0,"","Payment Voucher")
+27 IF '$DATA(GECSFMS("DA"))
SET X="No new FMS Payment Voucher created - Files inaccessible at this time.*"
DO MSG^PRCFQ
+28 QUIT
End DoDot:1
if '$DATA(GECSFMS("DA"))
GOTO EX
+29 IF $DATA(PRCFA("ERROR PROCESSING"))
SET CODESHET=0
Begin DoDot:1
+30 IF $GET(^%ZOSF("TEST"))
SET X="GECSSGET"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET X="Generic Code Sheet routine GECSSGET missing - cannot continue.*"
DO MSG^PRCFQ
QUIT
+31 SET DOCID="PV-"_XPO
DO DATA^GECSSGET(DOCID,CODESHET)
+32 IF '$DATA(GECSDATA)
SET X="FMS Payment Voucher not rebuilt or transmitted - could not locate original PV in local stack file.*"
DO MSG^PRCFQ
QUIT
+33 SET PRCFD("STACK")=GECSDATA
+34 IF $GET(^%ZOSF("TEST"))
SET X="GECSUFM1"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET X="Generic Code Sheet routine GECSUFM1 missing - cannot continue.*"
DO MSG^PRCFQ
KILL GECSDATA
QUIT
+35 DO REBUILD^GECSUFM1(GECSDATA,"I",$$SEC1^PRC0C(PRC("SITE")),"","Payment Voucher Retransmission")
+36 QUIT
End DoDot:1
if '$DATA(GECSDATA)
GOTO EX
+37 IF $DATA(GECSFMS("DA"))=0
IF +$GET(PRCFD("STACK"))
SET GECSFMS("DA")=PRCFD("STACK")
+38 IF $GET(^%ZOSF("TEST"))
SET X="GECSSTAA"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET X="Generic Code Sheet routine GECSSTAA missing - cannot continue.*"
DO MSG^PRCFQ
GOTO EX
+39 SET IX=0
FOR
SET IX=$ORDER(^TMP($JOB,"PRCPV",IX))
if 'IX
QUIT
DO SETCS^GECSSTAA(GECSFMS("DA"),^(IX))
+40 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+41 SET X="PV document is complete and is queued for transmission to FMS.*"
+42 ; Save GECS Stack File PV # in Invoice record:
+43 SET DIE=421.5
SET DA=PRCF("CIDA")
SET DR="27///^S X=XPO"
DO ^DIE
KILL DA,DIE,DR
+44 DO MSG^PRCFQ
SET X=20
DO STATUS^PRCFDE1
+45 ; Post FMS Document Information to Purchase Order:
+46 SET PRCFA("SYS")="FMS"
SET PRCFA("PODA")=PRCF("PODA")
SET POESIG=1
+47 SET XA="PV"
SET XB=0
if ACTION="M"
SET XB=1
+48 SET XC=$PIECE($GET(^PRCF(421.5,PRCF("CIDA"),1)),U,19)
if XC=""
SET XC=$PIECE(^PRCF(421.5,PRCF("CIDA"),0),U,5)
+49 SET XD=$PIECE(PRCF("PO"),"-",2)
+50 DO EN7^PRCFFU41(XA,XB,XC,XD)
EX if $DATA(PRCF("CIDA"))
LOCK -^PRCF(421.5,PRCF("CIDA"))
+1 KILL ACTION,N1,XPO,IX,XA,XB,XC,XD,DOCID,GECSDATA,GECSFMS,POESIG
+2 KILL BOC,CNT,LAMT,D0,LD,FMSTYPE,GO,LABEL,LOOP
+3 KILL RECORD,RECORD1,RESP,RETRAN,STATUS,TXT,VAR,PRCFX,MOP,PO,PONUM,PRC
+4 KILL PRCF,PRCFD,PRC10DA,PRCTXD,X,Y,FMSLN,IEN,DIC
+5 KILL PRCTMP,PATDA,CODESHET
+6 KILL ^TMP($JOB,"PRCPV")
+7 IF $DATA(PRCFA("ERROR PROCESSING"))
IF PRCFA("ERROR PROCESSING")'=2
KILL PRCFA
QUIT
+8 KILL PRCFA
+9 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIRUT)!$DATA(DIROUT)
KILL DUOUT,DTOUT,DIRUT,DIROUT
QUIT
+10 GOTO ^PRCFDA
+11 ;
DATE(A,B) ;Returns in external format, the greater of Today and the
+1 ;original obligation date
+2 NEW X,Y
SET X=$PIECE($PIECE($GET(^PRC(442,A,10,B,0)),U),".",3)
+3 if X'=""
SET X=$SELECT(+$EXTRACT(X,5,6)<80:3,1:2)_$EXTRACT(X,5,6)_$EXTRACT(X,1,2)_$EXTRACT(X,3,4)
+4 if $PIECE($GET(DT),".")>X
SET X=$PIECE(DT,".")
+5 SET Y=$PIECE("JAN~FEB~MAR~APR~MAY~JUN~JUL~AUG~SEP~OCT~NOV~DEC","~",+$EXTRACT(X,4,5))
+6 SET Y=Y_" "_+$EXTRACT(X,6,7)_", "_(1700+$EXTRACT(X,1,3))
+7 QUIT Y
MONYR(X) ;Returns External Month and Day from FileMan Date
+1 NEW Y
+2 IF X'?7N.E
SET Y=""
QUIT Y
+3 SET Y=$PIECE("JAN~FEB~MAR~APR~MAY~JUN~JUL~AUG~SEP~OCT~NOV~DEC","~",+$EXTRACT(X,4,5))
+4 SET Y=Y_" "_(1700+$EXTRACT(X,1,3))
+5 QUIT Y
ASK ; If there are more than one BOC on the obligation ask the user for
+1 ; the BOC to be processed.
+2 SET DIR(0)="NO"
+3 NEW PRCFBOC
SET PRCFBOC=""
+4 SET DIR("A")="Select FMS LINE BOC: "
+5 SET DIR("B")=$ORDER(PRCFX("SA",PRCFBOC))
+6 SET DIR("?")="^D HELP^PRCFDA2"
+7 SET DIR("??")="^W !!?15,""You may only enter a BOC from Obligation ""_PRCF(""CIDA"")"
+8 DO ^DIR
IF $DATA(DIRUT)
SET PRCFEX=1
QUIT
+9 IF '$DATA(DIRUT)
SET PRCFFLG=1
+10 IF '$DATA(PRCFX("SA",X))
KILL X
WRITE "??"
GOTO BOC^PRCFDA
+11 SET BOC=Y
ASK2 ;checks to see if there are >1 FMS lines on a particular BOC
+1 ;also an entry pointfor when there is only 1 BOC to check to
+2 ;if there are >1 FMS line on that BOC
+3 NEW CNT2,PRCFEE,PRCNOBOC
SET CNT2=""
+4 SET PRCFNUM=""
FOR
SET PRCFNUM=$ORDER(PRCFX("SA",BOC,PRCFNUM))
if 'PRCFNUM
QUIT
SET CNT2=CNT2+1
+5 IF CNT2>1
Begin DoDot:1
+6 WRITE !!,"Choose from: "
+7 SET PRCFEE=""
FOR
SET PRCFEE=$ORDER(PRCFX("SA",BOC,PRCFEE))
if 'PRCFEE
QUIT
WRITE !?5,PRCFEE_" "_BOC_" "_$SELECT($PIECE($GET(PRCFX("SA",BOC,PRCFEE)),U,2)=991:"Shipping",1:"Goods/Services")
+8 SET DIR(0)="NOA"
+9 SET DIR("A")="Enter the number of your choice: "
+10 SET DIR("T")=30
+11 DO ^DIR
IF $DATA(DIRUT)
SET PRCFEXIT=1
QUIT
+12 IF '$DATA(DIRUT)
SET PRCFFLG=1
+13 IF '$DATA(PRCFX("SA",BOC,X))
KILL X
WRITE "??"
SET PRCNOBOC=1
+14 SET PRCFNUM=Y
+15 QUIT
End DoDot:1
IF $GET(PRCNOBOC)=1
GOTO BOC^PRCFDA
+16 IF CNT2=1
SET PRCFNUM=0
SET PRCFNUM=$ORDER(PRCFX("SA",BOC,PRCFNUM))
IF $GET(CNT1)=1
SET PRCFFLG=2
+17 QUIT
HELP ;Help for BOC look-up
+1 NEW NUM,NUM2
+2 WRITE ?5,"Answer with a BOC from this Obligation.",!
+3 SET NUM=""
+4 SET NUM=$ORDER(PRCFX("SA",NUM))
if 'NUM
QUIT
Begin DoDot:1
+5 IF $ORDER(PRCFX("SA",NUM))]""
WRITE !?10,"Choose from: "
QUIT
End DoDot:1
+6 SET (NUM,NUM2)=""
+7 FOR
SET NUM=$ORDER(PRCFX("SA",NUM))
if 'NUM
QUIT
Begin DoDot:1
+8 FOR
SET NUM2=$ORDER(PRCFX("SA",NUM,NUM2))
if 'NUM2
QUIT
Begin DoDot:2
+9 WRITE !?15,NUM," ",$SELECT($PIECE(PRCFX("SA",NUM,NUM2),U,2)=991:"Shipping",1:"Goods/Services")
End DoDot:2
End DoDot:1
+10 QUIT
