| 1 | PRCPUFCP ;WISC/RFJ/DGL-select fund control point utility ; 10.19.99
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ;
|
|---|
| 7 | SELECT(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 | ;
|
|---|
| 20 | SET(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 | ;
|
|---|
| 32 | DEL(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
|
|---|
