- PRCBBUL ;WISC@ALTOONA/CTB-BULLETIN FOR FUND DISTRIBUTION ; 07/07/93 2:26 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;CREATES A BULLETIN FOR TRANSACTION NUMBER (PRCB("TRDA") AND FORWARDS IT TO ALL USERS WHO ARE IDENTIFIED AS CONTROL POINT OFFICIALS OR CONTROL POINT CLERKS
- N CP,DA,DIC,DIWF,DIWL,DIWR,I,N,TRDA,UTIL,X,X2,XMDUZ,XMSUB,XMTEXT,XMY,Y
- S TRDA(0)=^PRCF(421,PRCB("TRDA"),0),TRDA(4)=$S($D(^(4)):^(4),1:""),CP=+$P(TRDA(0),"^",2) Q:CP=9999
- K UTIL,^UTILITY($J,"W")
- S UTIL(3,0)="",UTIL(4,0)="The following funding transaction has been released:",UTIL(5,0)=" "
- S UTIL(5.5,0)="Control Point: "_$P(TRDA(0),"^",2)
- I $P(TRDA(0),"^",4)]"" S Y=$P(TRDA(0),"^",5) D DD^%DT S UTIL(5.6,0)="TDA #: "_$P(TRDA(0),"^",4),$P(UTIL(5.6,0)," ",40)="TDA DATE: "_Y,UTIL(5.7,0)=" "
- S Y=$P(TRDA(0),"^",6) D DD^%DT S UTIL(6,0)="Transaction #: "_$P(TRDA(0),"^")_" Transaction Date: "_Y
- S UTIL(8,0)=" ",$P(FILL," ",40)=""
- S X=$P(TRDA(0),"^",7) D COMMA^%DTC S UTIL(9,0)="1st Qtr Amt: $"_X,UTIL(9,0)=UTIL(9,0)_$P(FILL," ",$L(UTIL(9,0)),40)_"Type: "_$S($P(TRDA(4),"^",6)="R":"Recurring",1:"Non-Recurring")
- S X=$P(TRDA(0),"^",8) D COMMA^%DTC S UTIL(10,0)="2nd Qtr Amt: $"_X
- S X=$P(TRDA(0),"^",9) D COMMA^%DTC S UTIL(11,0)="3rd Qtr Amt: $"_X S X=$P(TRDA(4),"^",5) I X'=0 D COMMA^%DTC S UTIL(11,0)=UTIL(11,0)_$P(FILL," ",$L(UTIL(11,0)),40)_"Annualization: $"_X
- S X=$P(TRDA(0),"^",10) D COMMA^%DTC S UTIL(12,0)="4th Qtr Amt: $"_X
- S X=0 F I=7:1:10 S X=X+$P(TRDA(0),"^",I)
- S UTIL(13,0)=" ___________ "
- D COMMA^%DTC S UTIL(14,0)=" Total Amt: $"_X
- S UTIL(15,0)=" "
- S X="DESCRIPTION: ",N=0,DIWL=1,DIWF="I5",DIWR=70 D DIWP^PRCUTL($G(DA)) F I=1:1 S N=$O(^PRCF(421,PRCB("TRDA"),1,N)) Q:N="" S X=^(N,0) D DIWP^PRCUTL($G(DA))
- F I=0:0 S I=$O(^UTILITY($J,"W",1,I)) Q:I="" S:$D(^(I,0)) UTIL(I+16,0)=^(0)
- S PRC("CP")=CP D NAMES
- S:$D(XMY)<10 XMY(DUZ)="" S XMSUB="Funding Transaction #: "_$P(TRDA(0),"^"),XMDUZ=DUZ,XMTEXT="UTIL(" D ^XMD
- K DIW,DIWI,DIWT,DIWTC,DIWX,DN,ER,XMKK,XMLOCK,XMQF,XMR,XMT,XMZ,Z Q
- NAMES ;GENERATES XMY ARRAY FOR MESSAGES TO CONTROL POINT OFFICIALS AND CLERKS. REQUIRES VARIABLES PRC("SITE") AND PRC("CP")
- N I,TMP,X
- K XMY F I=0:0 S I=$O(^PRC(420,+PRC("SITE"),1,+PRC("CP"),1,I)) Q:'I I $D(^(I,0)) S X=^(0) D
- .I $P(X,"^",3)["Y" S TMP(+X)=""
- .I '$D(TMP),12[$P(X,"^",2),$P(X,"^")]"" S XMY(+X)=""
- I $D(TMP) K XMY S %X="TMP(",%Y="XMY(" D %XY^%RCR
- Q
- COMMIT ;report of committed transactions for 1-n control points
- ;this report was created for the Coatesville IFCAP testers
- W !!,"This report will generate a display of committed ",!,"transactions for one or more control points which you select",!!
- START ;
- D EN1^PRCSUT Q:Y<0 I '$D(PRC("SITE")) W !,"This site is not entered in IFCAP." Q
- K ^TMP($J)
- Q:'$D(PRC("CP"))
- S PRC("CPP")=PRC("CP") W !!,"Enter control point at end of range.",!,"(For a range of 1-n, enter n. For one control point, enter that control point.)",!!
- D CP^PRCSUT
- K IO("Q") S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS
- Q:POP I $D(IO("Q")) S ZTRTN="PROCESS^PRCBBUL",ZTDESC="COMMITTED TRANSACTION LISTING",ZTSAVE("PRC*")="" D ^%ZTLOAD D ^%ZISC G START
- D PROCESS D ^%ZISC G START
- PROCESS ;
- S PRCSZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_"0000"
- S RANGE=$P(PRC("CPP")," ")-1
- S N=0,STOP=0,P1=0,QTR=PRC("QTR"),RANGE1=PRC("CP")+1 D NOW^%DTC S Y=% D DD^%DT S RDATE=Y
- S TYPE(0)="",TYPE("O")="OBLIGATION",TYPE("A")="ADJUSTMENT",TYPE("C")="CEILING",TYPE("CA")="CANCELLED"
- W @IOF
- F S PRCSZ=$O(^PRCS(410,"B",PRCSZ)) Q:$P(PRCSZ,"-",3)'=QTR I $P(PRCSZ,"-",4)>RANGE,$P(PRCSZ,"-",4)<RANGE1 D
- .S PRCDA=$O(^PRCS(410,"B",PRCSZ,0)) Q:+PRCDA=0
- .S STR=$G(^PRCS(410,PRCDA,0)),STR4=$G(^PRCS(410,PRCDA,4)),STRING=$P($G(STR),"^")_"^"_$P($G(STR),"^",2)_"^"_$P($G(STR4),"^")_"^"_PRCDA
- .S N=N+1 S ^TMP($J,+$P($G(STR4),"^",2),N)=STRING
- S N=0 F S N=$O(^TMP($J,N)) Q:N="" D
- .Q:STOP=U D:IOSL-$Y<8 HOLD1 Q:STOP=U
- .D:P1=0 HDR1 S Y=N D DD^%DT U IO W !,"DATE COMMITTED: ",?20,Y
- .S N1=0 F S N1=$O(^TMP($J,N,N1)) Q:N1="" D
- ..Q:STOP=U D:IOSL-$Y<8 HOLD1 Q:STOP=U
- ..S STRING=^TMP($J,N,N1),TRANS=$P(STRING,"^"),TYP=$P(STRING,"^",2),COMM=$P(STRING,"^",3),D0=$P(STRING,"^",4)
- ..D STATUS^PRCSES S STATUS=$E(X,1,30)
- ..U IO W !,TRANS,?21,TYPE(TYP),?34,$J(COMM,8,2),?50,STATUS
- I P1=0 U IO W !!,"No transactions were found for this quarter.",!!
- U IO(0) W !!,"End of report" K X,RDATE,Y,%,L,P1,STOP,TYPE,PRCDA,STRING,COMM,STATUS,D0,PRCSZ,PRC("CPP"),RANGE,RANGE1,QTR,STR,STR4,N,N1,TRANS,TYP
- K ^TMP($J) Q
- HOLD1 ;
- G HDR1:$D(ZTQUEUED),HDR1:IO'=IO(0)
- W !,"Press return to continue, uparrow (^) to exit: " R STOP:DTIME S:'$T STOP=U D:STOP'=U HDR1
- Q
- HDR1 ;
- S P1=P1+1
- U IO W @IOF W "COMMITTED TRANSACTIONS LISTING",?45,RDATE,?70,"PAGE ",P1
- W !,?34,"COMMITTED",!,?21,"TRANSACTION",?34,"(ESTIMATED)",!,"TRANSACTION NUMBER",?21,"TYPE",?39,"COST",?50,"STATUS"
- S STOP1=STOP
- S L="",$P(L,"-",IOM)="-" W !,L S L="" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBBUL 4960 printed Feb 18, 2025@23:26:57 Page 2
- PRCBBUL ;WISC@ALTOONA/CTB-BULLETIN FOR FUND DISTRIBUTION ; 07/07/93 2:26 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;CREATES A BULLETIN FOR TRANSACTION NUMBER (PRCB("TRDA") AND FORWARDS IT TO ALL USERS WHO ARE IDENTIFIED AS CONTROL POINT OFFICIALS OR CONTROL POINT CLERKS
- +3 NEW CP,DA,DIC,DIWF,DIWL,DIWR,I,N,TRDA,UTIL,X,X2,XMDUZ,XMSUB,XMTEXT,XMY,Y
- +4 SET TRDA(0)=^PRCF(421,PRCB("TRDA"),0)
- SET TRDA(4)=$SELECT($DATA(^(4)):^(4),1:"")
- SET CP=+$PIECE(TRDA(0),"^",2)
- if CP=9999
- QUIT
- +5 KILL UTIL,^UTILITY($JOB,"W")
- +6 SET UTIL(3,0)=""
- SET UTIL(4,0)="The following funding transaction has been released:"
- SET UTIL(5,0)=" "
- +7 SET UTIL(5.5,0)="Control Point: "_$PIECE(TRDA(0),"^",2)
- +8 IF $PIECE(TRDA(0),"^",4)]""
- SET Y=$PIECE(TRDA(0),"^",5)
- DO DD^%DT
- SET UTIL(5.6,0)="TDA #: "_$PIECE(TRDA(0),"^",4)
- SET $PIECE(UTIL(5.6,0)," ",40)="TDA DATE: "_Y
- SET UTIL(5.7,0)=" "
- +9 SET Y=$PIECE(TRDA(0),"^",6)
- DO DD^%DT
- SET UTIL(6,0)="Transaction #: "_$PIECE(TRDA(0),"^")_" Transaction Date: "_Y
- +10 SET UTIL(8,0)=" "
- SET $PIECE(FILL," ",40)=""
- +11 SET X=$PIECE(TRDA(0),"^",7)
- DO COMMA^%DTC
- SET UTIL(9,0)="1st Qtr Amt: $"_X
- SET UTIL(9,0)=UTIL(9,0)_$PIECE(FILL," ",$LENGTH(UTIL(9,0)),40)_"Type: "_$SELECT($PIECE(TRDA(4),"^",6)="R":"Recurring",1:"Non-Recurring")
- +12 SET X=$PIECE(TRDA(0),"^",8)
- DO COMMA^%DTC
- SET UTIL(10,0)="2nd Qtr Amt: $"_X
- +13 SET X=$PIECE(TRDA(0),"^",9)
- DO COMMA^%DTC
- SET UTIL(11,0)="3rd Qtr Amt: $"_X
- SET X=$PIECE(TRDA(4),"^",5)
- IF X'=0
- DO COMMA^%DTC
- SET UTIL(11,0)=UTIL(11,0)_$PIECE(FILL," ",$LENGTH(UTIL(11,0)),40)_"Annualization: $"_X
- +14 SET X=$PIECE(TRDA(0),"^",10)
- DO COMMA^%DTC
- SET UTIL(12,0)="4th Qtr Amt: $"_X
- +15 SET X=0
- FOR I=7:1:10
- SET X=X+$PIECE(TRDA(0),"^",I)
- +16 SET UTIL(13,0)=" ___________ "
- +17 DO COMMA^%DTC
- SET UTIL(14,0)=" Total Amt: $"_X
- +18 SET UTIL(15,0)=" "
- +19 SET X="DESCRIPTION: "
- SET N=0
- SET DIWL=1
- SET DIWF="I5"
- SET DIWR=70
- DO DIWP^PRCUTL($GET(DA))
- FOR I=1:1
- SET N=$ORDER(^PRCF(421,PRCB("TRDA"),1,N))
- if N=""
- QUIT
- SET X=^(N,0)
- DO DIWP^PRCUTL($GET(DA))
- +20 FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"W",1,I))
- if I=""
- QUIT
- if $DATA(^(I,0))
- SET UTIL(I+16,0)=^(0)
- +21 SET PRC("CP")=CP
- DO NAMES
- +22 if $DATA(XMY)<10
- SET XMY(DUZ)=""
- SET XMSUB="Funding Transaction #: "_$PIECE(TRDA(0),"^")
- SET XMDUZ=DUZ
- SET XMTEXT="UTIL("
- DO ^XMD
- +23 KILL DIW,DIWI,DIWT,DIWTC,DIWX,DN,ER,XMKK,XMLOCK,XMQF,XMR,XMT,XMZ,Z
- QUIT
- NAMES ;GENERATES XMY ARRAY FOR MESSAGES TO CONTROL POINT OFFICIALS AND CLERKS. REQUIRES VARIABLES PRC("SITE") AND PRC("CP")
- +1 NEW I,TMP,X
- +2 KILL XMY
- FOR I=0:0
- SET I=$ORDER(^PRC(420,+PRC("SITE"),1,+PRC("CP"),1,I))
- if 'I
- QUIT
- IF $DATA(^(I,0))
- SET X=^(0)
- Begin DoDot:1
- +3 IF $PIECE(X,"^",3)["Y"
- SET TMP(+X)=""
- +4 IF '$DATA(TMP)
- IF 12[$PIECE(X,"^",2)
- IF $PIECE(X,"^")]""
- SET XMY(+X)=""
- End DoDot:1
- +5 IF $DATA(TMP)
- KILL XMY
- SET %X="TMP("
- SET %Y="XMY("
- DO %XY^%RCR
- +6 QUIT
- COMMIT ;report of committed transactions for 1-n control points
- +1 ;this report was created for the Coatesville IFCAP testers
- +2 WRITE !!,"This report will generate a display of committed ",!,"transactions for one or more control points which you select",!!
- START ;
- +1 DO EN1^PRCSUT
- if Y<0
- QUIT
- IF '$DATA(PRC("SITE"))
- WRITE !,"This site is not entered in IFCAP."
- QUIT
- +2 KILL ^TMP($JOB)
- +3 if '$DATA(PRC("CP"))
- QUIT
- +4 SET PRC("CPP")=PRC("CP")
- WRITE !!,"Enter control point at end of range.",!,"(For a range of 1-n, enter n. For one control point, enter that control point.)",!!
- +5 DO CP^PRCSUT
- +6 KILL IO("Q")
- SET %ZIS("B")="HOME"
- SET %ZIS="MQ"
- DO ^%ZIS
- +7 if POP
- QUIT
- IF $DATA(IO("Q"))
- SET ZTRTN="PROCESS^PRCBBUL"
- SET ZTDESC="COMMITTED TRANSACTION LISTING"
- SET ZTSAVE("PRC*")=""
- DO ^%ZTLOAD
- DO ^%ZISC
- GOTO START
- +8 DO PROCESS
- DO ^%ZISC
- GOTO START
- PROCESS ;
- +1 SET PRCSZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_"0000"
- +2 SET RANGE=$PIECE(PRC("CPP")," ")-1
- +3 SET N=0
- SET STOP=0
- SET P1=0
- SET QTR=PRC("QTR")
- SET RANGE1=PRC("CP")+1
- DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET RDATE=Y
- +4 SET TYPE(0)=""
- SET TYPE("O")="OBLIGATION"
- SET TYPE("A")="ADJUSTMENT"
- SET TYPE("C")="CEILING"
- SET TYPE("CA")="CANCELLED"
- +5 WRITE @IOF
- +6 FOR
- SET PRCSZ=$ORDER(^PRCS(410,"B",PRCSZ))
- if $PIECE(PRCSZ,"-",3)'=QTR
- QUIT
- IF $PIECE(PRCSZ,"-",4)>RANGE
- IF $PIECE(PRCSZ,"-",4)<RANGE1
- Begin DoDot:1
- +7 SET PRCDA=$ORDER(^PRCS(410,"B",PRCSZ,0))
- if +PRCDA=0
- QUIT
- +8 SET STR=$GET(^PRCS(410,PRCDA,0))
- SET STR4=$GET(^PRCS(410,PRCDA,4))
- SET STRING=$PIECE($GET(STR),"^")_"^"_$PIECE($GET(STR),"^",2)_"^"_$PIECE($GET(STR4),"^")_"^"_PRCDA
- +9 SET N=N+1
- SET ^TMP($JOB,+$PIECE($GET(STR4),"^",2),N)=STRING
- End DoDot:1
- +10 SET N=0
- FOR
- SET N=$ORDER(^TMP($JOB,N))
- if N=""
- QUIT
- Begin DoDot:1
- +11 if STOP=U
- QUIT
- if IOSL-$Y<8
- DO HOLD1
- if STOP=U
- QUIT
- +12 if P1=0
- DO HDR1
- SET Y=N
- DO DD^%DT
- USE IO
- WRITE !,"DATE COMMITTED: ",?20,Y
- +13 SET N1=0
- FOR
- SET N1=$ORDER(^TMP($JOB,N,N1))
- if N1=""
- QUIT
- Begin DoDot:2
- +14 if STOP=U
- QUIT
- if IOSL-$Y<8
- DO HOLD1
- if STOP=U
- QUIT
- +15 SET STRING=^TMP($JOB,N,N1)
- SET TRANS=$PIECE(STRING,"^")
- SET TYP=$PIECE(STRING,"^",2)
- SET COMM=$PIECE(STRING,"^",3)
- SET D0=$PIECE(STRING,"^",4)
- +16 DO STATUS^PRCSES
- SET STATUS=$EXTRACT(X,1,30)
- +17 USE IO
- WRITE !,TRANS,?21,TYPE(TYP),?34,$JUSTIFY(COMM,8,2),?50,STATUS
- End DoDot:2
- End DoDot:1
- +18 IF P1=0
- USE IO
- WRITE !!,"No transactions were found for this quarter.",!!
- +19 USE IO(0)
- WRITE !!,"End of report"
- KILL X,RDATE,Y,%,L,P1,STOP,TYPE,PRCDA,STRING,COMM,STATUS,D0,PRCSZ,PRC("CPP"),RANGE,RANGE1,QTR,STR,STR4,N,N1,TRANS,TYP
- +20 KILL ^TMP($JOB)
- QUIT
- HOLD1 ;
- +1 if $DATA(ZTQUEUED)
- GOTO HDR1
- if IO'=IO(0)
- GOTO HDR1
- +2 WRITE !,"Press return to continue, uparrow (^) to exit: "
- READ STOP:DTIME
- if '$TEST
- SET STOP=U
- if STOP'=U
- DO HDR1
- +3 QUIT
- HDR1 ;
- +1 SET P1=P1+1
- +2 USE IO
- WRITE @IOF
- WRITE "COMMITTED TRANSACTIONS LISTING",?45,RDATE,?70,"PAGE ",P1
- +3 WRITE !,?34,"COMMITTED",!,?21,"TRANSACTION",?34,"(ESTIMATED)",!,"TRANSACTION NUMBER",?21,"TYPE",?39,"COST",?50,"STATUS"
- +4 SET STOP1=STOP
- +5 SET L=""
- SET $PIECE(L,"-",IOM)="-"
- WRITE !,L
- SET L=""
- QUIT