PRCVMON ;ISC-SF/GJW;Monitor subscriptions ; 6/6/05 3:48pm
;;5.1;IFCAP;**81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
INIT ;Create initial set of FCP balances
N I,J,K,IENS,OUT,STAT,FCP
N IENS1,BAL,NODE
S I=""
F S I=$O(^PRCV(414.03,"AC",1,I)) Q:I="" D
.S IENS=I_","
.D GETS^DIQ(414.03,IENS,"@;.01;.02","I","OUT")
.S STAT=$G(OUT(414.03,IENS,.01,"I"))
.S FCP=$G(OUT(414.03,IENS,.02,"I"))
.K OUT
.S J=0
.;The pattern match is needed because IENs in this subfile
.;are actually strings, not (canonic) numbers
.F S J=$O(^PRC(420,STAT,1,FCP,4,J)) Q:((J="")!(J?1.A)) D
..;Unfortunately, an IEN of "00" confuses Fileman, so it is
..;necessary to use a global read instead of a Fileman call.
..I $$FY4(J)'<$$GETFY D
...S NODE=$G(^PRC(420,STAT,1,FCP,4,J,0))
...F K=1:1:4 D
....S BAL(K)=+$P(NODE,"^",K+1)
...D UPD(STAT,FCP,J,.BAL)
Q
;
;Reset values to contents of PRCVAL
RESET(PRCVAL) ;
N STAT,FCP,FY,I,MYBAL
S STAT=""
F S STAT=$O(@PRCVAL@(STAT)) Q:STAT="" D
.S FY=""
.F S FY=$O(@PRCVAL@(STAT,FY)) Q:FY="" D
..I $$FY4(FY)'<$$GETFY D
...S FCP=""
...F S FCP=$O(@PRCVAL@(STAT,FY,FCP)) Q:FCP="" D
....F I=1:1:4 D
.....S MYBAL(I)=$G(@PRCVAL@(STAT,FY,FCP,I))
....;update 414.03
....D UPD(STAT,FCP,FY,.MYBAL)
Q
;
;Schedule the task
SCHED ;
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTPRI,ZTSK
;Quit if not a DM site
I '$$CHK D Q
.W !,"This task may not be scheduled at a non-Dynamed site."
I $$ISRUN D Q
.W !,$C(7),"The FCP monitor is already running!"
;
;Go ahead and schedule the task
S ZTRTN="RUN^PRCVMON"
S ZTDESC="FCP Balance Monitor"
S ZTDTH=$H ;right now
S ZTIO=""
S ZTPRI=3
D ^%ZTLOAD
D ISQED^%ZTLOAD
I $L($G(ZTSK(0)))>0 D
.D SETRUN(1)
.W !,"The FCP monitor (task # ",$G(ZTSK),") was scheduled"
.W " to run at ",$$HTE^XLFDT(ZTSK("D"))
Q
;
DIFF(PRCVX,PRCVY) ;
N T1,T2,VAL
;check for wrap-around
I PRCVY<PRCVX D
.S T1=86400-PRCVX
.S T2=PRCVY
.S VAL=T1+T2
Q:PRCVY<PRCVX VAL
S VAL=PRCVY-PRCVX
Q VAL
;
RUN ;
N STAT,FCP,OUT,OUT1,OUT2,FY,FY2,FYIEN,VAL,VAL2,DELTA
N I,J,K,IX,IENS,IENS1,IENS2,IENS3,MROOT,PRCVQUIT
S PRCVSTRT=$P($H,",",2)
S DELTA=0
;Quit if not a DM site
I '$$CHK D Q
.D SETRUN(0)
N $ET,$ES S $ET="D TRAP^PRCVMON"
;
D INIT ;initialize 414.03 from 420 (one time only)
S PRCVQUIT=0
;loop through the active subscriptions
LOOP ;
H 1 ;breathing room
;Asked to stop?
S:$D(PRCVEND) DELTA=+$G(DELTA)+$$DIFF(PRCVSTRT,PRCVEND)
I +$G(DELTA)'<120 D
.I $$S^%ZTLOAD S PRCVQUIT=1
.I $$SHLDSTP S PRCVQUIT=1
.S PRCVSTRT=$P($H,",",2)
.S DELTA=0
G:PRCVQUIT DONE
ONCE ;
S VAL=$NA(^TMP("PRCVAL",$J)) ;values from 420
S VAL2=$NA(^TMP("PRCVAL2",$J)) ;values from 414.03
;
;for each subscription type
S I=""
F S I=$O(^PRCV(414.03,"AC",1,I)) Q:I="" D
.S IENS=I_","
.D GETS^DIQ(414.03,IENS,"@;.01;.02","I","OUT")
.S STAT=$G(OUT(414.03,IENS,.01,"I"))
.S FCP=$G(OUT(414.03,IENS,.02,"I"))
.K OUT
.;get a list of values from file 420
.S IENS1=","_FCP_","_STAT_","
.D LIST^DIC(420.06,IENS1,"@;.01;1;2;3;4","P",,,,"B",,,"OUT1")
.S J=""
.F S J=$O(OUT1("DILIST",J)) Q:J="" D
..S FYIEN=$P($G(OUT1("DILIST",J,0)),"^",1)
..S FY=$P($G(OUT1("DILIST",J,0)),"^",2)
..I $$FY4(FY)'<$$GETFY D
...S @VAL@(STAT,FY,FCP,1)=$P($G(OUT1("DILIST",J,0)),"^",3)
...S @VAL@(STAT,FY,FCP,2)=$P($G(OUT1("DILIST",J,0)),"^",4)
...S @VAL@(STAT,FY,FCP,3)=$P($G(OUT1("DILIST",J,0)),"^",5)
...S @VAL@(STAT,FY,FCP,4)=$P($G(OUT1("DILIST",J,0)),"^",6)
.K OUT1
.S K=0
.F S K=$O(^PRCV(414.03,I,1,K)) Q:+K'>0 D
..S IENS2=K_","_I_","
..S FY2=$$GET1^DIQ(414.031,IENS2,.01)
..S IENS3=","_IENS2
..D LIST^DIC(414.0311,IENS3,"@;.01;1","P",,,,"B",,,"OUT2","MROOT")
..I $$FY4(FY2)'<$$GETFY D
...F IX=1:1:4 D
....S @VAL2@(STAT,FY2,FCP,IX)=$P($G(OUT2("DILIST",IX,0)),"^",3)
...K OUT2
;Reset the values in 414.03
;The old values are not needed, as they have been captured in ^TMP.
D RESET(VAL)
;Now, compare the values
D COMP2(VAL,VAL2)
K @VAL,@VAL2
H 10 ;breathing room
S PRCVEND=$P($H,",",2) ;seconds since midnight
Q:'$D(PRCVQUIT)
G LOOP
DONE ;
K PRCVSTRT,PRCVEND
D SETRUN(0)
Q
;
COMP2(PRCVNEW,PRCVOLD) ;
N STAT,FY,FCP,PRCVTMP1,PRCVTMP2
S STAT=""
F S STAT=$O(@PRCVNEW@(STAT)) Q:STAT="" D
.S FY=""
.F S FY=$O(@PRCVNEW@(STAT,FY)) Q:FY="" D
..S FCP=""
..F S FCP=$O(@PRCVNEW@(STAT,FY,FCP)) Q:FCP="" D
...K PRCVTMP1,PRCVTMP2
...M PRCVTMP1=@PRCVNEW@(STAT,FY,FCP)
...M PRCVTMP2=@PRCVOLD@(STAT,FY,FCP)
...D CHECK(.PRCVTMP1,.PRCVTMP2,STAT,FY,FCP)
K PRCVTMP1,PRCVTMP2
Q
;
CHECK(PRCVNBAL,PRCVOBAL,PRCVSTAT,PRCVFY,PRCVCP) ;
N I,CHG
Q:$$FY4(PRCVFY)<$$GETFY ;don't send anything for past years
S CHG=0 ;assume no change
F I=1:1:4 I +$G(PRCVNBAL(I))'=+$G(PRCVOBAL(I)) S CHG=1
I CHG D SEND(PRCVSTAT,PRCVFY,PRCVCP,.PRCVNBAL)
Q
;
SEND(PRCVSTAT,PRCVFY,PRCVCP,PRCVBAL) ;
N OBJ,PROTO,MYOPTNS,MYRES
S OBJ=$NA(^TMP($J,"PRCV_FBAL"))
S @OBJ@("TIME")=$$NOW^XLFDT
S @OBJ@("STAT")=$G(PRCVSTAT)
S @OBJ@("FCP_NUM")=$G(PRCVCP)
S @OBJ@("FY")=$G(PRCVFY)
S @OBJ@("1QBAL")=$G(PRCVBAL(1))
S @OBJ@("2QBAL")=$G(PRCVBAL(2))
S @OBJ@("3QBAL")=$G(PRCVBAL(3))
S @OBJ@("4QBAL")=$G(PRCVBAL(4))
D BLD1^PRCVBLD(OBJ)
S PROTO="PRCV_DYNAMED_22_EV_FUND_BAL_DATA"
S MYOPTNS("NAMESPACE")="PRCV"
D GENERATE^HLMA(PROTO,"GM",1,.MYRES,,.MYOPTNS)
K @OBJ
Q
;
;Update 414.03
UPD(PRCVSTAT,PRCVFCP,PRCVFY,PRCVBAL) ;
N OUT,VAL,IEN,IENS1,IENS2,MYFDA,I
N MROOT
S VAL(1)=PRCVSTAT
S VAL(2)=PRCVFCP
S VAL(3)=1
D FIND^DIC(414.03,,"@;.01;.02;.03","KX",.VAL,,,,,"OUT","MROOT")
S IEN=$G(OUT("DILIST",2,1))
S IENS1="?+1"_","_IEN_","
S MYFDA(414.031,IENS1,.01)=PRCVFY
S I=""
F S I=$O(PRCVBAL(I)) Q:I="" D
.S IENS2="?+"_(I+1)_","_IENS1
.S MYFDA(414.0311,IENS2,.01)=I
.S MYFDA(414.0311,IENS2,1)=$G(PRCVBAL(I))
D UPDATE^DIE("EK","MYFDA",,"MROOT")
Q
;
TRAP ;
;clear the 'run' flag
D SETRUN(0)
;Have the temporary globals been deleted?
S VAL=$G(VAL),VAL2=$G(VAL2)
I VAL?1"^".E1"(".E K @VAL
I VAL2?1"^".E1"(".E K @VAL2
D ^%ZTER
D UNWIND^%ZTER
Q
;
;Provide a convenient way to enable/disable monitor
GETSTAT() ;
N PRMY,IENS
S PRMY=$$PSTAT
S IENS=PRMY_","
Q +$$GET1^DIQ(411,IENS,106,"I")
;
SETSTAT(PRCVST) ;
N FDA,IENS,PRMY,STATE
S PRCVST=$G(PRCVST)
S STATE=$$EXTERNAL^DILFD(411,106,,PRCVST)
I STATE="" D Q
.W:IO=IO(0) !,"Invalid status!"
W:IO=IO(0) !,"Setting status to ",STATE
S PRMY=$$PSTAT
S IENS=PRMY_","
S FDA(411,IENS,106)=PRCVST
D UPDATE^DIE("","FDA")
Q
;
SETRUN(PRCVST) ;
N FDA,IENS,PRMY
S PRCVST=+$G(PRCVST)
Q:((PRCVST'=0)&(PRCVST'=1))
S PRMY=$$PSTAT
S IENS=PRMY_","
S FDA(411,IENS,107)=PRCVST
D UPDATE^DIE("","FDA")
Q
ISRUN() ;
N PRMY,IENS
S PRMY=$$PSTAT
S IENS=PRMY_","
Q +$$GET1^DIQ(411,IENS,107,"I")
;
GETFY() ;
N DATE,YEAR,MON,FY
;Get the calendar year
S DATE=$$DT^XLFDT
S YEAR=($E(DATE,1)+17)*100+$E(DATE,2,3)
S MON=+$E(DATE,4,5)
S FY=$S(MON>9:YEAR+1,1:YEAR)
Q FY
;
FY4(PRCVFY) ;
I $L(PRCVFY)'<4 Q PRCVFY
I +$G(PRCVFY)'<30 Q 1900+PRCVFY
Q 2000+PRCVFY
;
;Various simple checks
CHK() ;
Q $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
;
;Primary station
PSTAT() ;
N PRMY
I '$D(^PRC(411,"AC","Y")) Q 0 ;no primary station in x-ref
Q $O(^PRC(411,"AC","Y",""))
;
;Should the monitor stop?
SHLDSTP() ;
N FLG
S FLG=$$GETSTAT
Q $S(FLG=0:1,FLG=1:0,FLG=2:1,1:1)
;
PUSH1(PRCVSTAT,PRCVFY,PRCVCP) ;
N OBJ,PROTO,MYOPTNS,MYRES
S OBJ=$NA(^TMP($J,"PRCV_FBAL"))
S @OBJ@("TIME")=$$NOW^XLFDT
S @OBJ@("STAT")=$G(PRCVSTAT)
S @OBJ@("FCP_NUM")=$G(PRCVCP)
S @OBJ@("FY")=$G(PRCVFY)
S @OBJ@("1QBAL")=+$P($G(^PRC(420,PRCVSTAT,1,PRCVCP,4,PRCVFY,0)),"^",2)
S @OBJ@("2QBAL")=+$P($G(^PRC(420,PRCVSTAT,1,PRCVCP,4,PRCVFY,0)),"^",3)
S @OBJ@("3QBAL")=+$P($G(^PRC(420,PRCVSTAT,1,PRCVCP,4,PRCVFY,0)),"^",4)
S @OBJ@("4QBAL")=+$P($G(^PRC(420,PRCVSTAT,1,PRCVCP,4,PRCVFY,0)),"^",5)
D BLD1^PRCVBLD(OBJ)
S PROTO="PRCV_DYNAMED_22_EV_FUND_BAL_DATA"
S MYOPTNS("NAMESPACE")="PRCV"
D GENERATE^HLMA(PROTO,"GM",1,.MYRES,,.MYOPTNS)
;W:IO=IO(0) !,"Message generated: ",$P(MYRES,"^",1)
K @OBJ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVMON 8236 printed Nov 22, 2024@17:30:12 Page 2
PRCVMON ;ISC-SF/GJW;Monitor subscriptions ; 6/6/05 3:48pm
+1 ;;5.1;IFCAP;**81**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
INIT ;Create initial set of FCP balances
+1 NEW I,J,K,IENS,OUT,STAT,FCP
+2 NEW IENS1,BAL,NODE
+3 SET I=""
+4 FOR
SET I=$ORDER(^PRCV(414.03,"AC",1,I))
if I=""
QUIT
Begin DoDot:1
+5 SET IENS=I_","
+6 DO GETS^DIQ(414.03,IENS,"@;.01;.02","I","OUT")
+7 SET STAT=$GET(OUT(414.03,IENS,.01,"I"))
+8 SET FCP=$GET(OUT(414.03,IENS,.02,"I"))
+9 KILL OUT
+10 SET J=0
+11 ;The pattern match is needed because IENs in this subfile
+12 ;are actually strings, not (canonic) numbers
+13 FOR
SET J=$ORDER(^PRC(420,STAT,1,FCP,4,J))
if ((J="")!(J?1.A))
QUIT
Begin DoDot:2
+14 ;Unfortunately, an IEN of "00" confuses Fileman, so it is
+15 ;necessary to use a global read instead of a Fileman call.
+16 IF $$FY4(J)'<$$GETFY
Begin DoDot:3
+17 SET NODE=$GET(^PRC(420,STAT,1,FCP,4,J,0))
+18 FOR K=1:1:4
Begin DoDot:4
+19 SET BAL(K)=+$PIECE(NODE,"^",K+1)
End DoDot:4
+20 DO UPD(STAT,FCP,J,.BAL)
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
+23 ;Reset values to contents of PRCVAL
RESET(PRCVAL) ;
+1 NEW STAT,FCP,FY,I,MYBAL
+2 SET STAT=""
+3 FOR
SET STAT=$ORDER(@PRCVAL@(STAT))
if STAT=""
QUIT
Begin DoDot:1
+4 SET FY=""
+5 FOR
SET FY=$ORDER(@PRCVAL@(STAT,FY))
if FY=""
QUIT
Begin DoDot:2
+6 IF $$FY4(FY)'<$$GETFY
Begin DoDot:3
+7 SET FCP=""
+8 FOR
SET FCP=$ORDER(@PRCVAL@(STAT,FY,FCP))
if FCP=""
QUIT
Begin DoDot:4
+9 FOR I=1:1:4
Begin DoDot:5
+10 SET MYBAL(I)=$GET(@PRCVAL@(STAT,FY,FCP,I))
End DoDot:5
+11 ;update 414.03
+12 DO UPD(STAT,FCP,FY,.MYBAL)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
+15 ;Schedule the task
SCHED ;
+1 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTPRI,ZTSK
+2 ;Quit if not a DM site
+3 IF '$$CHK
Begin DoDot:1
+4 WRITE !,"This task may not be scheduled at a non-Dynamed site."
End DoDot:1
QUIT
+5 IF $$ISRUN
Begin DoDot:1
+6 WRITE !,$CHAR(7),"The FCP monitor is already running!"
End DoDot:1
QUIT
+7 ;
+8 ;Go ahead and schedule the task
+9 SET ZTRTN="RUN^PRCVMON"
+10 SET ZTDESC="FCP Balance Monitor"
+11 ;right now
SET ZTDTH=$HOROLOG
+12 SET ZTIO=""
+13 SET ZTPRI=3
+14 DO ^%ZTLOAD
+15 DO ISQED^%ZTLOAD
+16 IF $LENGTH($GET(ZTSK(0)))>0
Begin DoDot:1
+17 DO SETRUN(1)
+18 WRITE !,"The FCP monitor (task # ",$GET(ZTSK),") was scheduled"
+19 WRITE " to run at ",$$HTE^XLFDT(ZTSK("D"))
End DoDot:1
+20 QUIT
+21 ;
DIFF(PRCVX,PRCVY) ;
+1 NEW T1,T2,VAL
+2 ;check for wrap-around
+3 IF PRCVY<PRCVX
Begin DoDot:1
+4 SET T1=86400-PRCVX
+5 SET T2=PRCVY
+6 SET VAL=T1+T2
End DoDot:1
+7 if PRCVY<PRCVX
QUIT VAL
+8 SET VAL=PRCVY-PRCVX
+9 QUIT VAL
+10 ;
RUN ;
+1 NEW STAT,FCP,OUT,OUT1,OUT2,FY,FY2,FYIEN,VAL,VAL2,DELTA
+2 NEW I,J,K,IX,IENS,IENS1,IENS2,IENS3,MROOT,PRCVQUIT
+3 SET PRCVSTRT=$PIECE($HOROLOG,",",2)
+4 SET DELTA=0
+5 ;Quit if not a DM site
+6 IF '$$CHK
Begin DoDot:1
+7 DO SETRUN(0)
End DoDot:1
QUIT
+8 NEW $ETRAP,$ESTACK
SET $ETRAP="D TRAP^PRCVMON"
+9 ;
+10 ;initialize 414.03 from 420 (one time only)
DO INIT
+11 SET PRCVQUIT=0
+12 ;loop through the active subscriptions
LOOP ;
+1 ;breathing room
HANG 1
+2 ;Asked to stop?
+3 if $DATA(PRCVEND)
SET DELTA=+$GET(DELTA)+$$DIFF(PRCVSTRT,PRCVEND)
+4 IF +$GET(DELTA)'<120
Begin DoDot:1
+5 IF $$S^%ZTLOAD
SET PRCVQUIT=1
+6 IF $$SHLDSTP
SET PRCVQUIT=1
+7 SET PRCVSTRT=$PIECE($HOROLOG,",",2)
+8 SET DELTA=0
End DoDot:1
+9 if PRCVQUIT
GOTO DONE
ONCE ;
+1 ;values from 420
SET VAL=$NAME(^TMP("PRCVAL",$JOB))
+2 ;values from 414.03
SET VAL2=$NAME(^TMP("PRCVAL2",$JOB))
+3 ;
+4 ;for each subscription type
+5 SET I=""
+6 FOR
SET I=$ORDER(^PRCV(414.03,"AC",1,I))
if I=""
QUIT
Begin DoDot:1
+7 SET IENS=I_","
+8 DO GETS^DIQ(414.03,IENS,"@;.01;.02","I","OUT")
+9 SET STAT=$GET(OUT(414.03,IENS,.01,"I"))
+10 SET FCP=$GET(OUT(414.03,IENS,.02,"I"))
+11 KILL OUT
+12 ;get a list of values from file 420
+13 SET IENS1=","_FCP_","_STAT_","
+14 DO LIST^DIC(420.06,IENS1,"@;.01;1;2;3;4","P",,,,"B",,,"OUT1")
+15 SET J=""
+16 FOR
SET J=$ORDER(OUT1("DILIST",J))
if J=""
QUIT
Begin DoDot:2
+17 SET FYIEN=$PIECE($GET(OUT1("DILIST",J,0)),"^",1)
+18 SET FY=$PIECE($GET(OUT1("DILIST",J,0)),"^",2)
+19 IF $$FY4(FY)'<$$GETFY
Begin DoDot:3
+20 SET @VAL@(STAT,FY,FCP,1)=$PIECE($GET(OUT1("DILIST",J,0)),"^",3)
+21 SET @VAL@(STAT,FY,FCP,2)=$PIECE($GET(OUT1("DILIST",J,0)),"^",4)
+22 SET @VAL@(STAT,FY,FCP,3)=$PIECE($GET(OUT1("DILIST",J,0)),"^",5)
+23 SET @VAL@(STAT,FY,FCP,4)=$PIECE($GET(OUT1("DILIST",J,0)),"^",6)
End DoDot:3
End DoDot:2
+24 KILL OUT1
+25 SET K=0
+26 FOR
SET K=$ORDER(^PRCV(414.03,I,1,K))
if +K'>0
QUIT
Begin DoDot:2
+27 SET IENS2=K_","_I_","
+28 SET FY2=$$GET1^DIQ(414.031,IENS2,.01)
+29 SET IENS3=","_IENS2
+30 DO LIST^DIC(414.0311,IENS3,"@;.01;1","P",,,,"B",,,"OUT2","MROOT")
+31 IF $$FY4(FY2)'<$$GETFY
Begin DoDot:3
+32 FOR IX=1:1:4
Begin DoDot:4
+33 SET @VAL2@(STAT,FY2,FCP,IX)=$PIECE($GET(OUT2("DILIST",IX,0)),"^",3)
End DoDot:4
+34 KILL OUT2
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;Reset the values in 414.03
+36 ;The old values are not needed, as they have been captured in ^TMP.
+37 DO RESET(VAL)
+38 ;Now, compare the values
+39 DO COMP2(VAL,VAL2)
+40 KILL @VAL,@VAL2
+41 ;breathing room
HANG 10
+42 ;seconds since midnight
SET PRCVEND=$PIECE($HOROLOG,",",2)
+43 if '$DATA(PRCVQUIT)
QUIT
+44 GOTO LOOP
DONE ;
+1 KILL PRCVSTRT,PRCVEND
+2 DO SETRUN(0)
+3 QUIT
+4 ;
COMP2(PRCVNEW,PRCVOLD) ;
+1 NEW STAT,FY,FCP,PRCVTMP1,PRCVTMP2
+2 SET STAT=""
+3 FOR
SET STAT=$ORDER(@PRCVNEW@(STAT))
if STAT=""
QUIT
Begin DoDot:1
+4 SET FY=""
+5 FOR
SET FY=$ORDER(@PRCVNEW@(STAT,FY))
if FY=""
QUIT
Begin DoDot:2
+6 SET FCP=""
+7 FOR
SET FCP=$ORDER(@PRCVNEW@(STAT,FY,FCP))
if FCP=""
QUIT
Begin DoDot:3
+8 KILL PRCVTMP1,PRCVTMP2
+9 MERGE PRCVTMP1=@PRCVNEW@(STAT,FY,FCP)
+10 MERGE PRCVTMP2=@PRCVOLD@(STAT,FY,FCP)
+11 DO CHECK(.PRCVTMP1,.PRCVTMP2,STAT,FY,FCP)
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL PRCVTMP1,PRCVTMP2
+13 QUIT
+14 ;
CHECK(PRCVNBAL,PRCVOBAL,PRCVSTAT,PRCVFY,PRCVCP) ;
+1 NEW I,CHG
+2 ;don't send anything for past years
if $$FY4(PRCVFY)<$$GETFY
QUIT
+3 ;assume no change
SET CHG=0
+4 FOR I=1:1:4
IF +$GET(PRCVNBAL(I))'=+$GET(PRCVOBAL(I))
SET CHG=1
+5 IF CHG
DO SEND(PRCVSTAT,PRCVFY,PRCVCP,.PRCVNBAL)
+6 QUIT
+7 ;
SEND(PRCVSTAT,PRCVFY,PRCVCP,PRCVBAL) ;
+1 NEW OBJ,PROTO,MYOPTNS,MYRES
+2 SET OBJ=$NAME(^TMP($JOB,"PRCV_FBAL"))
+3 SET @OBJ@("TIME")=$$NOW^XLFDT
+4 SET @OBJ@("STAT")=$GET(PRCVSTAT)
+5 SET @OBJ@("FCP_NUM")=$GET(PRCVCP)
+6 SET @OBJ@("FY")=$GET(PRCVFY)
+7 SET @OBJ@("1QBAL")=$GET(PRCVBAL(1))
+8 SET @OBJ@("2QBAL")=$GET(PRCVBAL(2))
+9 SET @OBJ@("3QBAL")=$GET(PRCVBAL(3))
+10 SET @OBJ@("4QBAL")=$GET(PRCVBAL(4))
+11 DO BLD1^PRCVBLD(OBJ)
+12 SET PROTO="PRCV_DYNAMED_22_EV_FUND_BAL_DATA"
+13 SET MYOPTNS("NAMESPACE")="PRCV"
+14 DO GENERATE^HLMA(PROTO,"GM",1,.MYRES,,.MYOPTNS)
+15 KILL @OBJ
+16 QUIT
+17 ;
+18 ;Update 414.03
UPD(PRCVSTAT,PRCVFCP,PRCVFY,PRCVBAL) ;
+1 NEW OUT,VAL,IEN,IENS1,IENS2,MYFDA,I
+2 NEW MROOT
+3 SET VAL(1)=PRCVSTAT
+4 SET VAL(2)=PRCVFCP
+5 SET VAL(3)=1
+6 DO FIND^DIC(414.03,,"@;.01;.02;.03","KX",.VAL,,,,,"OUT","MROOT")
+7 SET IEN=$GET(OUT("DILIST",2,1))
+8 SET IENS1="?+1"_","_IEN_","
+9 SET MYFDA(414.031,IENS1,.01)=PRCVFY
+10 SET I=""
+11 FOR
SET I=$ORDER(PRCVBAL(I))
if I=""
QUIT
Begin DoDot:1
+12 SET IENS2="?+"_(I+1)_","_IENS1
+13 SET MYFDA(414.0311,IENS2,.01)=I
+14 SET MYFDA(414.0311,IENS2,1)=$GET(PRCVBAL(I))
End DoDot:1
+15 DO UPDATE^DIE("EK","MYFDA",,"MROOT")
+16 QUIT
+17 ;
TRAP ;
+1 ;clear the 'run' flag
+2 DO SETRUN(0)
+3 ;Have the temporary globals been deleted?
+4 SET VAL=$GET(VAL)
SET VAL2=$GET(VAL2)
+5 IF VAL?1"^".E1"(".E
KILL @VAL
+6 IF VAL2?1"^".E1"(".E
KILL @VAL2
+7 DO ^%ZTER
+8 DO UNWIND^%ZTER
+9 QUIT
+10 ;
+11 ;Provide a convenient way to enable/disable monitor
GETSTAT() ;
+1 NEW PRMY,IENS
+2 SET PRMY=$$PSTAT
+3 SET IENS=PRMY_","
+4 QUIT +$$GET1^DIQ(411,IENS,106,"I")
+5 ;
SETSTAT(PRCVST) ;
+1 NEW FDA,IENS,PRMY,STATE
+2 SET PRCVST=$GET(PRCVST)
+3 SET STATE=$$EXTERNAL^DILFD(411,106,,PRCVST)
+4 IF STATE=""
Begin DoDot:1
+5 if IO=IO(0)
WRITE !,"Invalid status!"
End DoDot:1
QUIT
+6 if IO=IO(0)
WRITE !,"Setting status to ",STATE
+7 SET PRMY=$$PSTAT
+8 SET IENS=PRMY_","
+9 SET FDA(411,IENS,106)=PRCVST
+10 DO UPDATE^DIE("","FDA")
+11 QUIT
+12 ;
SETRUN(PRCVST) ;
+1 NEW FDA,IENS,PRMY
+2 SET PRCVST=+$GET(PRCVST)
+3 if ((PRCVST'=0)&(PRCVST'=1))
QUIT
+4 SET PRMY=$$PSTAT
+5 SET IENS=PRMY_","
+6 SET FDA(411,IENS,107)=PRCVST
+7 DO UPDATE^DIE("","FDA")
+8 QUIT
ISRUN() ;
+1 NEW PRMY,IENS
+2 SET PRMY=$$PSTAT
+3 SET IENS=PRMY_","
+4 QUIT +$$GET1^DIQ(411,IENS,107,"I")
+5 ;
GETFY() ;
+1 NEW DATE,YEAR,MON,FY
+2 ;Get the calendar year
+3 SET DATE=$$DT^XLFDT
+4 SET YEAR=($EXTRACT(DATE,1)+17)*100+$EXTRACT(DATE,2,3)
+5 SET MON=+$EXTRACT(DATE,4,5)
+6 SET FY=$SELECT(MON>9:YEAR+1,1:YEAR)
+7 QUIT FY
+8 ;
FY4(PRCVFY) ;
+1 IF $LENGTH(PRCVFY)'<4
QUIT PRCVFY
+2 IF +$GET(PRCVFY)'<30
QUIT 1900+PRCVFY
+3 QUIT 2000+PRCVFY
+4 ;
+5 ;Various simple checks
CHK() ;
+1 QUIT $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
+2 ;
+3 ;Primary station
PSTAT() ;
+1 NEW PRMY
+2 ;no primary station in x-ref
IF '$DATA(^PRC(411,"AC","Y"))
QUIT 0
+3 QUIT $ORDER(^PRC(411,"AC","Y",""))
+4 ;
+5 ;Should the monitor stop?
SHLDSTP() ;
+1 NEW FLG
+2 SET FLG=$$GETSTAT
+3 QUIT $SELECT(FLG=0:1,FLG=1:0,FLG=2:1,1:1)
+4 ;
PUSH1(PRCVSTAT,PRCVFY,PRCVCP) ;
+1 NEW OBJ,PROTO,MYOPTNS,MYRES
+2 SET OBJ=$NAME(^TMP($JOB,"PRCV_FBAL"))
+3 SET @OBJ@("TIME")=$$NOW^XLFDT
+4 SET @OBJ@("STAT")=$GET(PRCVSTAT)
+5 SET @OBJ@("FCP_NUM")=$GET(PRCVCP)
+6 SET @OBJ@("FY")=$GET(PRCVFY)
+7 SET @OBJ@("1QBAL")=+$PIECE($GET(^PRC(420,PRCVSTAT,1,PRCVCP,4,PRCVFY,0)),"^",2)
+8 SET @OBJ@("2QBAL")=+$PIECE($GET(^PRC(420,PRCVSTAT,1,PRCVCP,4,PRCVFY,0)),"^",3)
+9 SET @OBJ@("3QBAL")=+$PIECE($GET(^PRC(420,PRCVSTAT,1,PRCVCP,4,PRCVFY,0)),"^",4)
+10 SET @OBJ@("4QBAL")=+$PIECE($GET(^PRC(420,PRCVSTAT,1,PRCVCP,4,PRCVFY,0)),"^",5)
+11 DO BLD1^PRCVBLD(OBJ)
+12 SET PROTO="PRCV_DYNAMED_22_EV_FUND_BAL_DATA"
+13 SET MYOPTNS("NAMESPACE")="PRCV"
+14 DO GENERATE^HLMA(PROTO,"GM",1,.MYRES,,.MYOPTNS)
+15 ;W:IO=IO(0) !,"Message generated: ",$P(MYRES,"^",1)
+16 KILL @OBJ
+17 QUIT
