- 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 Jan 18, 2025@03:17:21 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