source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUFCP.m@ 1582

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

initial load of WorldVistAEHR

File size: 1.4 KB
Line 
1PRCPUFCP ;WISC/RFJ/DGL-select fund control point utility ; 10.19.99
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7SELECT(TYPE) ; select fund control point
8 ; if type (of inventory point set) use screen for lookup
9 N %,C,DA,DIC,DISYS,X,Y
10 I '$D(^PRC(420,+$G(PRC("SITE")),0)) Q 0
11 I '$D(^PRC(420,PRC("SITE"),1,0)) S ^(0)="^420.01^^"
12 S DIC="^PRC(420,"_PRC("SITE")_",1,",DA(1)=PRC("SITE"),DIC(0)="QEAMZ"
13 S DIC("W")="D DISPIP^PRCPUTIL(Y)"
14 S DIC("S")="I $O(^PRC(420,PRC(""SITE""),1,+Y,1,0))"
15 I TYPE'="" S DIC("S")=DIC("S")_","_$S(TYPE="W":"$P(^PRC(420,PRC(""SITE""),1,+Y,0),U,12)=2",1:"$P(^PRC(420,PRC(""SITE""),1,+Y,0),U,12)'=2")
16 W ! D ^DIC
17 Q +Y
18 ;
19 ;
20SET(FCPDA,INVPT) ; set invpt to fund control point
21 I '$D(^PRC(420,$G(PRC("SITE")),1,+FCPDA,0)) Q
22 I $D(^PRC(420,"AE",$G(PRC("SITE")),INVPT,+FCPDA)) Q
23 N %,D,D0,DA,DI,DIC,DIE,DO,DQ,DR,X,Y,PRCPPRIV
24 S PRCPPRIV=1
25 S DIC="^PRC(420,"_PRC("SITE")_",1,"_+FCPDA_",7,",X=INVPT
26 S DIC("P")=$P(^DD(420.01,17.5,0),U,2)
27 S DA(1)=+FCPDA,DA(2)=PRC("SITE"),DIC(0)="L",DLAYGO=420
28 D FILE^DICN
29 Q
30 ;
31 ;
32DEL(FCPDA,INVPT) ; delete invpt from control point
33 I '$D(^PRC(420,"AE",$G(PRC("SITE")),INVPT,+FCPDA)) Q
34 N %,DA,DIC,DIK,X,Y
35 S DA=0
36 S DA=$O(^PRC(420,PRC("SITE"),1,+FCPDA,7,"B",INVPT,DA)) Q:'DA
37 S DIK="^PRC(420,"_PRC("SITE")_",1,"_FCPDA_",7,"
38 S DA(1)=+FCPDA,DA(2)=PRC("SITE"),X=INVPT
39 D ^DIK
40 Q
41 ;
42 ;
43 ; PRCPUFCP
Note: See TracBrowser for help on using the repository browser.