PRCPUFCP ;WISC/RFJ/DGL-select fund control point utility ; 10.19.99
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
SELECT(TYPE) ; select fund control point
; if type (of inventory point set) use screen for lookup
N %,C,DA,DIC,DISYS,X,Y
I '$D(^PRC(420,+$G(PRC("SITE")),0)) Q 0
I '$D(^PRC(420,PRC("SITE"),1,0)) S ^(0)="^420.01^^"
S DIC="^PRC(420,"_PRC("SITE")_",1,",DA(1)=PRC("SITE"),DIC(0)="QEAMZ"
S DIC("W")="D DISPIP^PRCPUTIL(Y)"
S DIC("S")="I $O(^PRC(420,PRC(""SITE""),1,+Y,1,0))"
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")
W ! D ^DIC
Q +Y
;
;
SET(FCPDA,INVPT) ; set invpt to fund control point
I '$D(^PRC(420,$G(PRC("SITE")),1,+FCPDA,0)) Q
I $D(^PRC(420,"AE",$G(PRC("SITE")),INVPT,+FCPDA)) Q
N %,D,D0,DA,DI,DIC,DIE,DO,DQ,DR,X,Y,PRCPPRIV
S PRCPPRIV=1
S DIC="^PRC(420,"_PRC("SITE")_",1,"_+FCPDA_",7,",X=INVPT
S DIC("P")=$P(^DD(420.01,17.5,0),U,2)
S DA(1)=+FCPDA,DA(2)=PRC("SITE"),DIC(0)="L",DLAYGO=420
D FILE^DICN
Q
;
;
DEL(FCPDA,INVPT) ; delete invpt from control point
I '$D(^PRC(420,"AE",$G(PRC("SITE")),INVPT,+FCPDA)) Q
N %,DA,DIC,DIK,X,Y
S DA=0
S DA=$O(^PRC(420,PRC("SITE"),1,+FCPDA,7,"B",INVPT,DA)) Q:'DA
S DIK="^PRC(420,"_PRC("SITE")_",1,"_FCPDA_",7,"
S DA(1)=+FCPDA,DA(2)=PRC("SITE"),X=INVPT
D ^DIK
Q
;
;
; PRCPUFCP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUFCP 1472 printed Oct 16, 2024@18:16:54 Page 2
PRCPUFCP ;WISC/RFJ/DGL-select fund control point utility ; 10.19.99
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
SELECT(TYPE) ; select fund control point
+1 ; if type (of inventory point set) use screen for lookup
+2 NEW %,C,DA,DIC,DISYS,X,Y
+3 IF '$DATA(^PRC(420,+$GET(PRC("SITE")),0))
QUIT 0
+4 IF '$DATA(^PRC(420,PRC("SITE"),1,0))
SET ^(0)="^420.01^^"
+5 SET DIC="^PRC(420,"_PRC("SITE")_",1,"
SET DA(1)=PRC("SITE")
SET DIC(0)="QEAMZ"
+6 SET DIC("W")="D DISPIP^PRCPUTIL(Y)"
+7 SET DIC("S")="I $O(^PRC(420,PRC(""SITE""),1,+Y,1,0))"
+8 IF TYPE'=""
SET DIC("S")=DIC("S")_","_$SELECT(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")
+9 WRITE !
DO ^DIC
+10 QUIT +Y
+11 ;
+12 ;
SET(FCPDA,INVPT) ; set invpt to fund control point
+1 IF '$DATA(^PRC(420,$GET(PRC("SITE")),1,+FCPDA,0))
QUIT
+2 IF $DATA(^PRC(420,"AE",$GET(PRC("SITE")),INVPT,+FCPDA))
QUIT
+3 NEW %,D,D0,DA,DI,DIC,DIE,DO,DQ,DR,X,Y,PRCPPRIV
+4 SET PRCPPRIV=1
+5 SET DIC="^PRC(420,"_PRC("SITE")_",1,"_+FCPDA_",7,"
SET X=INVPT
+6 SET DIC("P")=$PIECE(^DD(420.01,17.5,0),U,2)
+7 SET DA(1)=+FCPDA
SET DA(2)=PRC("SITE")
SET DIC(0)="L"
SET DLAYGO=420
+8 DO FILE^DICN
+9 QUIT
+10 ;
+11 ;
DEL(FCPDA,INVPT) ; delete invpt from control point
+1 IF '$DATA(^PRC(420,"AE",$GET(PRC("SITE")),INVPT,+FCPDA))
QUIT
+2 NEW %,DA,DIC,DIK,X,Y
+3 SET DA=0
+4 SET DA=$ORDER(^PRC(420,PRC("SITE"),1,+FCPDA,7,"B",INVPT,DA))
if 'DA
QUIT
+5 SET DIK="^PRC(420,"_PRC("SITE")_",1,"_FCPDA_",7,"
+6 SET DA(1)=+FCPDA
SET DA(2)=PRC("SITE")
SET X=INVPT
+7 DO ^DIK
+8 QUIT
+9 ;
+10 ;
+11 ; PRCPUFCP
