- 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 Feb 18, 2025@23:26:29 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 ;