source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSAPP2.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1PRCSAPP2 ;WISC/KMB/BGJ/SC-CONTINUATION OF PRCSAPP ; 3/31/05 3:07pm
2V ;;5.1;IFCAP;**14,81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;PRC*5.1*81-if a 2237 trx is being approved & it originated from
6 ;DynaMed RIL then update DM re. approval thru a call to rtn PRCVTAP
7 ;
8FINAL ; ask if request was reviewed. print request if needed.
9 ;
10 N PRCSDA,PRCPRIB,RPRINT,REPLY,REPLY1 S (REPLY,REPLY1)=2
11 ; SKIPRNT is set in PRCSEB - official can approve request here
12 ; immediately after creating it in PRCSEB
13 I '$D(SKIPRNT) S %=0 W !,"Requests need to be reviewed prior to approval.",!,"Have you reviewed this request" D YN^DICN Q:%=-1 I %=0 W !,"Enter yes or no.",! H 1 G FINAL
14 I '$D(SKIPRNT),%=2 S (PRCS,PRCPRIB)=DA,TRNODE(0)=0 D:PRCHQ=1 NODE^PRCS58OB(DA,.TRNODE) S RPRINT=$S(PRCHQ=1:"^PRCE58P0",PRCHQ=5:"DQ^PRCPRIB0",1:"^PRCSD12") D @RPRINT S DA=PRCS
15 ;ask for approval, signature
16 N PRCOKCB S PRCOKCB=$$OKCCBOC^PRCSCK($P(PRCSN,"^"))
17 I PRCOKCB S %=1 W !,"Is this request ready for approval" D YN^DICN W:%=0 !,"Enter yes or no.",! G:%=0 FINAL Q:%=-1 S REPLY=%
18 I 'PRCOKCB S REPLY=2
19 ;
20FINAL1 ;*******************************************************************
21 ;PRCVDM -flag helps in determining if ans is Y to transmit to Fiscal
22 ;then ONLY pass the data to DynaMed for DM related approved 2237
23 ;*******************************************************************
24 N PRCVDM
25 I REPLY=1 W !,"Is this request ready for transmission to A&MM/Fiscal" S %=2 D YN^DICN Q:%=-1 S REPLY1=% S:%=1 PRCVDM=1 I %=0 W !,"Enter yes or no.",! H 1 G FINAL1
26 ; if ready for approval (or reviewed), store on cross-ref F,F1
27 D:REPLY=2 W5^PRCSEB D:REPLY=1 W51^PRCSEB Q:REPLY1=2
28 I $D(SKIPRNT) S MESSAGE="" D ESIG^PRCUESIG(DUZ,.MESSAGE) Q:MESSAGE'=1
29 ;********************************************************************
30 ;all of the line item data that we need to pass to DM on a DM related
31 ;trx. is recorded in the file 410 at this point for an approved 2237
32 ;********************************************************************
33 I $D(PRCVDM),PRCVDM=1 D EN^PRCVTAP(DA)
34 ;
35 ; set record in 443, clean up 410, change cp uncommitted balance
36 ; using TRANS^PRCSES, in 420
37 D NOW^%DTC S PRCS=%
38 S PRCSCP=$S($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$P(^(0),U,12),1:"")
39 N PPMFLG S:$D(PPMFLG1) PPMFLG=10
40 L +^PRCS(410,DA):15 Q:$T=0
41 S $P(^PRCS(410,DA,10),U,4)=$S(PRCSCP=1!(PRCHQ=1):$O(^PRCD(442.3,"C",10,0)),1:$O(^PRCD(442.3,"C",60,0))),$P(^(11),U,3)=""
42 N ESTSHIP,COST S ESTSHIP=$P($G(^PRCS(410,DA,9)),"^",4),COST=$P($G(^PRCS(410,DA,4)),"^",8)
43 N IJ F IJ=1,8 S $P(^PRCS(410,DA,4),"^",IJ)=ESTSHIP+COST
44 K ^PRCS(410,"F",+PRCSN_"-"_+PRC("CP")_"-"_$P($P(PRCSN,U),"-",5),DA),^PRCS(410,"F1",$P($P(PRCSN,U),"-",5)_"-"_+PRCSN_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
45 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)=""
46 D ERS410^PRC0G(DA_"^A")
47 ;
48 S MESSAGE=""
49 D ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
50 K MESSAGE
51 S X=PRCST D TRANS^PRCSES
52 ;
53 S PRCSSCP=0 F PRCSSI=1:1 S PRCSSCP=$O(^PRCS(410,DA,12,PRCSSCP)) Q:PRCSSCP'>0 I $D(^PRCS(410,DA,12,PRCSSCP,0)) S X=$P(^(0),U,2) I X S DA(1)=DA,DA=PRCSSCP D TRANS^PRCSEZZ S DA=DA(1)
54 K PRCSSCP,PRCSSI L -^PRCS(410,DA)
55 I $P(PRCSN,U,4)>1 S X=$P(PRCSN,U,1),DIC="^PRC(443,",DIC(0)="L",DLAYGO=443 D ^DIC K DIC,DLAYGO,X
56 I $P(PRCSN,U,4)>1 S X=$O(^PRCD(442.3,"C",60,0)) S:PRCSCP=1 X=$O(^PRCD(442.3,"C",10,0)) S $P(^PRC(443,DA,0),U,7)=X,^PRC(443,"AC",X,DA)="",$P(^PRC(443,DA,0),U,11)=$P(PRCSN,U,6)
57 D EN2^PRCPWI
58 S (PRCS,PRCPRIB)=DA,TRNODE(0)=0 D:PRCHQ=1 NODE^PRCS58OB(DA,.TRNODE)
59TAG ;
60 S PRCSDA=DA
61 S D0=DA,PRCHQ=$S(PRCHQ=1:"QUE^PRCE58P2",PRCHQ=5:"DQ^PRCPRIB0",1:"QUE^PRCSP12"),PRCHQ("DEST")=$S(PRCSCP=1!(PRCHQ="QUE^PRCE58P2"):"F",1:"S") D ^PRCHQUE S DA=PRCSDA Q
62 Q
63PRT ;
64 K IO("Q") S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS Q:POP
65 I $D(IO("Q")) S D0=$G(DA),ZTRTN=$S(PRCHQ=1:"QUE^PRCE58P2",PRCHQ=5:"DQ^PRCPRIB0",1:"^PRCSP12"),ZTSAVE("PRNTALL")="",ZTSAVE("DA")="",ZTSAVE("D0")="",ZTSAVE("PRC*")="",ZTSAVE("TRNODE*")="" D ^%ZTLOAD,^%ZISC Q
66 I IO=IO(0) U IO D:PRCHQ=5 DQ^PRCPRIB0 D:PRCHQ=1 ^PRCE58P0 D:PRCHQ'=1&(PRCHQ'=5) ^PRCSD12 D ^%ZISC W:$Y>0 @IOF Q
67 U IO D:PRCHQ=5 DQ^PRCPRIB0 D:PRCHQ=1 QUE^PRCE58P2 D:PRCHQ'=1&(PRCHQ'=5) ^PRCSP12 D ^%ZISC W:$Y>0 @IOF
68 QUIT
Note: See TracBrowser for help on using the repository browser.