PRC7B ;WISC/PLT-Receiver/Copy FND/PCL/PAC/CPF FMS message for V5 ; 06/29/94 2:30 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
;invoked from task manager (see trin^prcosrv2)
;copy conversion message to file 420.92
;PRCDA=ri of file 423.6 passed
EN ;Conversion message from sever FMS MESSAGE SEVER routine PRCOSRV2
N PRCRI,PRCTY,PRCERR,PRCSEQ,A,B
S PRCRI(423.6)=PRCDA,PRCTY=""
;check txn message
S PRCERR="",PRCSQE="" D CHECK(PRCRI(423.6))
I PRCERR D G EXIT
. N A,B,C
. S A(1)="IFCAP/FMS CONVERSION MESSAGE PAC/CPF/FND/PCL IS IN INVALID FORMAT."
. S A(2)="PLEASE CALL FMS-CONVERSION TEAM USER TO RESEND THIS MESSAGE:"
. S A(3)=$P($G(^PRCF(423.6,PRCDA,0)),"^")_" WITH IFCAP ERROR: "_PRCERR
. I PRCTY="" S B(.5)=""
. E S X=$$FIRST^PRC0B1("^PRCF(423.5,""B"""_",""CTL-"_PRCTY_""",",0) S X=$S(X:"G."_$$MG^PRC0B2($P(^PRCF(423.5,X,0),"^",2)),1:.5),B(X)=""
. S C="IFCAP/FMS CONVERSION ERROR MESSAGE-PAC/CPF/FND/PCL^IFCAP FMS MESSAGE SERVER"
. D MM^PRC0B2(C,"A(",.B)
. QUIT
;copy fms records to file 420.92
S A=$T(@PRCTY)
D COPY(PRCRI(423.6),$P(A," ",1)_"^"_$P(A,";",3,999))
I PRCERR D G EXIT
. N A,B,C
. S A(1)="IFCAP/FMS CONVERSION MESSAGE "_PRCTY_" COPY FAILURE"
. S A(2)="PLEASE CALL FMS-CONVERSION TEAM USER TO RESEND THIS MESSAGE:"
. S A(3)=$P($G(^PRCF(423.6,PRCDA,0)),"^")_" WITH IFCAP ERROR: "_PRCERR
. S X=$$FIRST^PRC0B1("^PRCF(423.5,""B"""_",""CTL-"_PRCTY_""",",0) S X=$S(X:"G."_$$MG^PRC0B2($P(^PRCF(423.5,X,0),"^",2)),1:.5),B(X)=""
. S C="IFCAP/FMS COPY ERROR MESSAGE-PAC/CPF/FND/PCL^IFCAP FMS MESSAGE SERVER"
. D MM^PRC0B2(C,"A(",.B)
. QUIT
;send copy done message
D
. N A,B,C
. S A(1)="IFCAP/FMS CONVERSION MESSAGE "_PRCTY_" COPY DONE."
. S A(2)="READY FOR CONVERSION THIS MESSAGE DURING POST-INITIAL IFCAP v.5"
. S A(3)=$P($G(^PRCF(423.6,PRCDA,0)),"^")
. S X=$$FIRST^PRC0B1("^PRCF(423.5,""B"""_",""CTL-"_PRCTY_""",",0) S X=$S(X:"G."_$$MG^PRC0B2($P(^PRCF(423.5,X,0),"^",2)),1:.5),B(X)=""
. S C="IFCAP/FMS COPY DONE MESSAGE-PAC/CPF/FND/PCL^IFCAP FMS MESSAGE SERVER"
. D MM^PRC0B2(C,"A(",.B)
. QUIT
;
EXIT ;delete fms conversion message in file 423.6
D KILL^PRCOSRV3(PRCRI(423.6))
QUIT
;
CHECK(PRCA,PRCB) ;PRCA=ri of file 423.6, PRCB=^1 txn class from FMS, ^2=description
N PRCC,PRCD,A
S PRCC=$O(^PRCF(423.6,PRCA,1,9999)) I 'PRCC S PRCERR=2 QUIT ;no message
S PRCD=$G(^PRCF(423.6,PRCA,1,PRCC,0)) I PRCD="" S PRCERR=2 QUIT
S PRCTY=$P(PRCD,"^",5),A="" S:PRCTY?1.5A A=$T(@PRCTY)
I $P(PRCD,"^")'="CTL"!(A="") S PRCERR=3,PRCTY="" QUIT ;wrong type
S PRCSEQ=+$P(PRCD,"^",13)_"-"_(+$P(PRCD,"^",14))
F S PRCC=$O(^PRCF(423.6,PRCA,1,PRCC)) Q:'PRCC S PRCD=^(PRCC,0)
I PRCD'="{" S PRCERR=4 QUIT ;missing txn delimeter
QUIT
;
COPY(PRCA,PRCB) ;PRCA=ri of file 423.6, PRCB=^1 txn class from FMS, ^2=description
N PRCC,PRCD,A,X,Y
S X=$P(PRCB,"^"),X("DR")="1////"_$P(PRCB,"^",2)_";2///^S X=""N"""_";5////"_PRCSEQ
D ADD^PRC0B1(.X,.Y,"420.92;^PRCU(420.92,")
I Y=-1 S PRCERR=101 QUIT ;copy failure
S PRCRI(420.92)=+Y
S PRCC=$O(^PRCF(423.6,PRCA,1,9999))
F S PRCC=$O(^PRCF(423.6,PRCA,1,PRCC)) Q:'PRCC S PRCD=^(PRCC,0) D:PRCD["~" Q:PRCERR
. S A="420.92;^PRCU(420.92,;"_PRCRI(420.92)_";3~420.923;^PRCU(420.92,"_PRCRI(420.92)_",1,"
. S X=0,X("DR")=".01///^S X=DA;1///^S X=$TR(PRCD,""^"",""~"")"
. D ADD^PRC0B1(.X,.Y,A) I Y=-1 S PRCERR=102
. QUIT
I 'PRCERR D EDIT^PRC0B(.X,"420.92;^PRCU(420.92,;"_PRCRI(420.92),"2.5///^S X=""N""","LS")
QUIT
;
;
PAC ;;STATION FCC/PRJ CONVERSION
CPF ;;STATION CONTROL POINT CONVERSION
FND ;;ALD/FUND CONVERSION
PCL ;;PROGRAM CONVERSION
SUB ;;SUB OBJECT CLASS
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC7B 3710 printed Apr 09, 2024@21:19:06 Page 2
PRC7B ;WISC/PLT-Receiver/Copy FND/PCL/PAC/CPF FMS message for V5 ; 06/29/94 2:30 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
+4 ;invoked from task manager (see trin^prcosrv2)
+5 ;copy conversion message to file 420.92
+6 ;PRCDA=ri of file 423.6 passed
EN ;Conversion message from sever FMS MESSAGE SEVER routine PRCOSRV2
+1 NEW PRCRI,PRCTY,PRCERR,PRCSEQ,A,B
+2 SET PRCRI(423.6)=PRCDA
SET PRCTY=""
+3 ;check txn message
+4 SET PRCERR=""
SET PRCSQE=""
DO CHECK(PRCRI(423.6))
+5 IF PRCERR
Begin DoDot:1
+6 NEW A,B,C
+7 SET A(1)="IFCAP/FMS CONVERSION MESSAGE PAC/CPF/FND/PCL IS IN INVALID FORMAT."
+8 SET A(2)="PLEASE CALL FMS-CONVERSION TEAM USER TO RESEND THIS MESSAGE:"
+9 SET A(3)=$PIECE($GET(^PRCF(423.6,PRCDA,0)),"^")_" WITH IFCAP ERROR: "_PRCERR
+10 IF PRCTY=""
SET B(.5)=""
+11 IF '$TEST
SET X=$$FIRST^PRC0B1("^PRCF(423.5,""B"""_",""CTL-"_PRCTY_""",",0)
SET X=$SELECT(X:"G."_$$MG^PRC0B2($PIECE(^PRCF(423.5,X,0),"^",2)),1:.5)
SET B(X)=""
+12 SET C="IFCAP/FMS CONVERSION ERROR MESSAGE-PAC/CPF/FND/PCL^IFCAP FMS MESSAGE SERVER"
+13 DO MM^PRC0B2(C,"A(",.B)
+14 QUIT
End DoDot:1
GOTO EXIT
+15 ;copy fms records to file 420.92
+16 SET A=$TEXT(@PRCTY)
+17 DO COPY(PRCRI(423.6),$PIECE(A," ",1)_"^"_$PIECE(A,";",3,999))
+18 IF PRCERR
Begin DoDot:1
+19 NEW A,B,C
+20 SET A(1)="IFCAP/FMS CONVERSION MESSAGE "_PRCTY_" COPY FAILURE"
+21 SET A(2)="PLEASE CALL FMS-CONVERSION TEAM USER TO RESEND THIS MESSAGE:"
+22 SET A(3)=$PIECE($GET(^PRCF(423.6,PRCDA,0)),"^")_" WITH IFCAP ERROR: "_PRCERR
+23 SET X=$$FIRST^PRC0B1("^PRCF(423.5,""B"""_",""CTL-"_PRCTY_""",",0)
SET X=$SELECT(X:"G."_$$MG^PRC0B2($PIECE(^PRCF(423.5,X,0),"^",2)),1:.5)
SET B(X)=""
+24 SET C="IFCAP/FMS COPY ERROR MESSAGE-PAC/CPF/FND/PCL^IFCAP FMS MESSAGE SERVER"
+25 DO MM^PRC0B2(C,"A(",.B)
+26 QUIT
End DoDot:1
GOTO EXIT
+27 ;send copy done message
+28 Begin DoDot:1
+29 NEW A,B,C
+30 SET A(1)="IFCAP/FMS CONVERSION MESSAGE "_PRCTY_" COPY DONE."
+31 SET A(2)="READY FOR CONVERSION THIS MESSAGE DURING POST-INITIAL IFCAP v.5"
+32 SET A(3)=$PIECE($GET(^PRCF(423.6,PRCDA,0)),"^")
+33 SET X=$$FIRST^PRC0B1("^PRCF(423.5,""B"""_",""CTL-"_PRCTY_""",",0)
SET X=$SELECT(X:"G."_$$MG^PRC0B2($PIECE(^PRCF(423.5,X,0),"^",2)),1:.5)
SET B(X)=""
+34 SET C="IFCAP/FMS COPY DONE MESSAGE-PAC/CPF/FND/PCL^IFCAP FMS MESSAGE SERVER"
+35 DO MM^PRC0B2(C,"A(",.B)
+36 QUIT
End DoDot:1
+37 ;
EXIT ;delete fms conversion message in file 423.6
+1 DO KILL^PRCOSRV3(PRCRI(423.6))
+2 QUIT
+3 ;
CHECK(PRCA,PRCB) ;PRCA=ri of file 423.6, PRCB=^1 txn class from FMS, ^2=description
+1 NEW PRCC,PRCD,A
+2 ;no message
SET PRCC=$ORDER(^PRCF(423.6,PRCA,1,9999))
IF 'PRCC
SET PRCERR=2
QUIT
+3 SET PRCD=$GET(^PRCF(423.6,PRCA,1,PRCC,0))
IF PRCD=""
SET PRCERR=2
QUIT
+4 SET PRCTY=$PIECE(PRCD,"^",5)
SET A=""
if PRCTY?1.5A
SET A=$TEXT(@PRCTY)
+5 ;wrong type
IF $PIECE(PRCD,"^")'="CTL"!(A="")
SET PRCERR=3
SET PRCTY=""
QUIT
+6 SET PRCSEQ=+$PIECE(PRCD,"^",13)_"-"_(+$PIECE(PRCD,"^",14))
+7 FOR
SET PRCC=$ORDER(^PRCF(423.6,PRCA,1,PRCC))
if 'PRCC
QUIT
SET PRCD=^(PRCC,0)
+8 ;missing txn delimeter
IF PRCD'="{"
SET PRCERR=4
QUIT
+9 QUIT
+10 ;
COPY(PRCA,PRCB) ;PRCA=ri of file 423.6, PRCB=^1 txn class from FMS, ^2=description
+1 NEW PRCC,PRCD,A,X,Y
+2 SET X=$PIECE(PRCB,"^")
SET X("DR")="1////"_$PIECE(PRCB,"^",2)_";2///^S X=""N"""_";5////"_PRCSEQ
+3 DO ADD^PRC0B1(.X,.Y,"420.92;^PRCU(420.92,")
+4 ;copy failure
IF Y=-1
SET PRCERR=101
QUIT
+5 SET PRCRI(420.92)=+Y
+6 SET PRCC=$ORDER(^PRCF(423.6,PRCA,1,9999))
+7 FOR
SET PRCC=$ORDER(^PRCF(423.6,PRCA,1,PRCC))
if 'PRCC
QUIT
SET PRCD=^(PRCC,0)
if PRCD["~"
Begin DoDot:1
+8 SET A="420.92;^PRCU(420.92,;"_PRCRI(420.92)_";3~420.923;^PRCU(420.92,"_PRCRI(420.92)_",1,"
+9 SET X=0
SET X("DR")=".01///^S X=DA;1///^S X=$TR(PRCD,""^"",""~"")"
+10 DO ADD^PRC0B1(.X,.Y,A)
IF Y=-1
SET PRCERR=102
+11 QUIT
End DoDot:1
if PRCERR
QUIT
+12 IF 'PRCERR
DO EDIT^PRC0B(.X,"420.92;^PRCU(420.92,;"_PRCRI(420.92),"2.5///^S X=""N""","LS")
+13 QUIT
+14 ;
+15 ;
PAC ;;STATION FCC/PRJ CONVERSION
CPF ;;STATION CONTROL POINT CONVERSION
FND ;;ALD/FUND CONVERSION
PCL ;;PROGRAM CONVERSION
SUB ;;SUB OBJECT CLASS
+1 ;
