PRCVSUB ;ISC-SF/GJW ; 6/6/05 11:38am
;;5.1;IFCAP;**81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
ADDSUB(PRCVSTAT,PRCVENT,PRCVTYP,PRCVMID) ;
N FDA,RESULT,MROOT,VAL,ERRNO
D ISEND(PRCVSTAT,PRCVENT)
S FDA(414.03,"?+1,",.01)=+$G(PRCVSTAT)
S FDA(414.03,"?+1,",.02)=$G(PRCVENT)
S FDA(414.03,"?+1,",.03)=$G(PRCVTYP)
S FDA(414.03,"?+1,",1)=$$NOW^XLFDT
S FDA(414.03,"?+1,",2)=1
S FDA(414.03,"?+1,",3)=$G(PRCVMID)
;need "E" because the type field is a set of codes
D UPDATE^DIE("EK","FDA","RESULT","MROOT")
I $D(MROOT("DIERR")) D ;error(s) occured
.S VAL="E",ERRNO=""
.F S ERRNO=$O(MROOT("DIERR","E",ERRNO)) Q:ERRNO="" D
..S VAL=VAL_"^"_ERRNO
E D
.S VAL=$G(RESULT(1,0))_"^"_$G(RESULT(1))
Q VAL
;
FINDSUB(PRCVSTAT,PRCVENT,PRCVTYP) ;
N OUT,MROOT,VALUES,VAL,ERRNO
S VALUES(1)=+$G(PRCVSTAT)
S VALUES(2)=$G(PRCVENT)
S VALUES(3)=$G(PRCVTYP)
S VAL=$$FIND1^DIC(414.03,,"K",.VALUES,,,"MROOT")
I $D(MROOT("DIERR")) D ;error(s) occured
.S VAL=-1,ERRNO=""
.F S ERRNO=$O(MROOT("DIERR","E",ERRNO)) Q:ERRNO="" D
..S VAL=VAL_"^"_ERRNO
Q VAL
;
DELSUB(PRCVSTAT,PRCVENT,PRCVTYP) ;
N VAL,IENS,MYFDA,MROOT,ERRNO
S VAL=$$FINDSUB(PRCVSTAT,PRCVENT,PRCVTYP)
Q:+VAL'>0 VAL
S IENS=+VAL_","
S MYFDA(414.03,IENS,.01)="@"
D FILE^DIE(,"MYFDA","MROOT")
Q:'$D(MROOT("DIERR")) "@^"_+VAL
;an error occured in FILE^DIE
S VAL="E",ERRNO=""
F S ERRNO=$O(MROOT("DIERR","E",ERRNO)) Q:ERRNO="" D
.S VAL=VAL_"^"_ERRNO
Q VAL
;
;immediate send
ISEND(PRCVSTAT,PRCVFCP) ;
N ROOT,I
S ROOT=$NA(^PRC(420,PRCVSTAT,1,PRCVFCP,4,"B"))
S I=""
F S I=$O(@ROOT@(I)) Q:I="" D
.I $$FY4^PRCVMON(I)'<$$GETFY^PRCVMON D
..D PUSH1^PRCVMON(PRCVSTAT,I,PRCVFCP)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVSUB 1748 printed Dec 13, 2024@02:20:19 Page 2
PRCVSUB ;ISC-SF/GJW ; 6/6/05 11:38am
+1 ;;5.1;IFCAP;**81**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ADDSUB(PRCVSTAT,PRCVENT,PRCVTYP,PRCVMID) ;
+1 NEW FDA,RESULT,MROOT,VAL,ERRNO
+2 DO ISEND(PRCVSTAT,PRCVENT)
+3 SET FDA(414.03,"?+1,",.01)=+$GET(PRCVSTAT)
+4 SET FDA(414.03,"?+1,",.02)=$GET(PRCVENT)
+5 SET FDA(414.03,"?+1,",.03)=$GET(PRCVTYP)
+6 SET FDA(414.03,"?+1,",1)=$$NOW^XLFDT
+7 SET FDA(414.03,"?+1,",2)=1
+8 SET FDA(414.03,"?+1,",3)=$GET(PRCVMID)
+9 ;need "E" because the type field is a set of codes
+10 DO UPDATE^DIE("EK","FDA","RESULT","MROOT")
+11 ;error(s) occured
IF $DATA(MROOT("DIERR"))
Begin DoDot:1
+12 SET VAL="E"
SET ERRNO=""
+13 FOR
SET ERRNO=$ORDER(MROOT("DIERR","E",ERRNO))
if ERRNO=""
QUIT
Begin DoDot:2
+14 SET VAL=VAL_"^"_ERRNO
End DoDot:2
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 SET VAL=$GET(RESULT(1,0))_"^"_$GET(RESULT(1))
End DoDot:1
+17 QUIT VAL
+18 ;
FINDSUB(PRCVSTAT,PRCVENT,PRCVTYP) ;
+1 NEW OUT,MROOT,VALUES,VAL,ERRNO
+2 SET VALUES(1)=+$GET(PRCVSTAT)
+3 SET VALUES(2)=$GET(PRCVENT)
+4 SET VALUES(3)=$GET(PRCVTYP)
+5 SET VAL=$$FIND1^DIC(414.03,,"K",.VALUES,,,"MROOT")
+6 ;error(s) occured
IF $DATA(MROOT("DIERR"))
Begin DoDot:1
+7 SET VAL=-1
SET ERRNO=""
+8 FOR
SET ERRNO=$ORDER(MROOT("DIERR","E",ERRNO))
if ERRNO=""
QUIT
Begin DoDot:2
+9 SET VAL=VAL_"^"_ERRNO
End DoDot:2
End DoDot:1
+10 QUIT VAL
+11 ;
DELSUB(PRCVSTAT,PRCVENT,PRCVTYP) ;
+1 NEW VAL,IENS,MYFDA,MROOT,ERRNO
+2 SET VAL=$$FINDSUB(PRCVSTAT,PRCVENT,PRCVTYP)
+3 if +VAL'>0
QUIT VAL
+4 SET IENS=+VAL_","
+5 SET MYFDA(414.03,IENS,.01)="@"
+6 DO FILE^DIE(,"MYFDA","MROOT")
+7 if '$DATA(MROOT("DIERR"))
QUIT "@^"_+VAL
+8 ;an error occured in FILE^DIE
+9 SET VAL="E"
SET ERRNO=""
+10 FOR
SET ERRNO=$ORDER(MROOT("DIERR","E",ERRNO))
if ERRNO=""
QUIT
Begin DoDot:1
+11 SET VAL=VAL_"^"_ERRNO
End DoDot:1
+12 QUIT VAL
+13 ;
+14 ;immediate send
ISEND(PRCVSTAT,PRCVFCP) ;
+1 NEW ROOT,I
+2 SET ROOT=$NAME(^PRC(420,PRCVSTAT,1,PRCVFCP,4,"B"))
+3 SET I=""
+4 FOR
SET I=$ORDER(@ROOT@(I))
if I=""
QUIT
Begin DoDot:1
+5 IF $$FY4^PRCVMON(I)'<$$GETFY^PRCVMON
Begin DoDot:2
+6 DO PUSH1^PRCVMON(PRCVSTAT,I,PRCVFCP)
End DoDot:2
End DoDot:1
+7 QUIT
