Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPUFCP

PRCPUFCP.m

Go to the documentation of this file.
  1. PRCPUFCP ;WISC/RFJ/DGL-select fund control point utility ; 10.19.99
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. SELECT(TYPE) ; select fund control point
  1. ; if type (of inventory point set) use screen for lookup
  1. N %,C,DA,DIC,DISYS,X,Y
  1. I '$D(^PRC(420,+$G(PRC("SITE")),0)) Q 0
  1. I '$D(^PRC(420,PRC("SITE"),1,0)) S ^(0)="^420.01^^"
  1. S DIC="^PRC(420,"_PRC("SITE")_",1,",DA(1)=PRC("SITE"),DIC(0)="QEAMZ"
  1. S DIC("W")="D DISPIP^PRCPUTIL(Y)"
  1. S DIC("S")="I $O(^PRC(420,PRC(""SITE""),1,+Y,1,0))"
  1. 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")
  1. W ! D ^DIC
  1. Q +Y
  1. ;
  1. ;
  1. SET(FCPDA,INVPT) ; set invpt to fund control point
  1. I '$D(^PRC(420,$G(PRC("SITE")),1,+FCPDA,0)) Q
  1. I $D(^PRC(420,"AE",$G(PRC("SITE")),INVPT,+FCPDA)) Q
  1. N %,D,D0,DA,DI,DIC,DIE,DO,DQ,DR,X,Y,PRCPPRIV
  1. S PRCPPRIV=1
  1. S DIC="^PRC(420,"_PRC("SITE")_",1,"_+FCPDA_",7,",X=INVPT
  1. S DIC("P")=$P(^DD(420.01,17.5,0),U,2)
  1. S DA(1)=+FCPDA,DA(2)=PRC("SITE"),DIC(0)="L",DLAYGO=420
  1. D FILE^DICN
  1. Q
  1. ;
  1. ;
  1. DEL(FCPDA,INVPT) ; delete invpt from control point
  1. I '$D(^PRC(420,"AE",$G(PRC("SITE")),INVPT,+FCPDA)) Q
  1. N %,DA,DIC,DIK,X,Y
  1. S DA=0
  1. S DA=$O(^PRC(420,PRC("SITE"),1,+FCPDA,7,"B",INVPT,DA)) Q:'DA
  1. S DIK="^PRC(420,"_PRC("SITE")_",1,"_FCPDA_",7,"
  1. S DA(1)=+FCPDA,DA(2)=PRC("SITE"),X=INVPT
  1. D ^DIK
  1. Q
  1. ;
  1. ;
  1. ; PRCPUFCP