- PRCSFMS1 ;WISC/KMB-FMS TRANSACTIONS FOR CP QUARTERLY REPORT ;10-17-94 11:05
- V ;;5.1;IFCAP;**90**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- BEGIN ; this routine is called from PRCSQR
- ; find FMS transactions, for selected quarter, for CP
- N Z1,FMSTOT,LINE,STRING,RDATE1,FIRST,FINAL,AMT,TYPE,MINUS,OBL,REF,RECNO,P1,PRCSAPP S (P1,Z1)=0
- D NOW^%DTC S Y=% D DD^%DT S RDATE1=Y
- S FMSTOT=0 S:'$D(PRCS("O")) PRCS("O")=0 S FINAL=PRCS("O"),STRING=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_+PRC("CP")
- S:'$D(PRCS("PRE")) PRCS("PRE")=0 S PRCSAPP=PRCS("PRE")
- S MINUS="" S:'$D(PRCS("C")) PRCS("C")=0 S FIRST=PRCS("C")
- S RECNO="" F S RECNO=$O(^PRCS(417,"C",STRING,RECNO)) Q:RECNO="" D Q:Z1=U
- .I P1=0 D HDR1
- .I IOSL-$Y<8 D HOLD1 Q:Z1=U
- .S AMT=$P(^PRCS(417,RECNO,0),"^",20),REF=$P(^(0),"^",22),OBL=$P(^(0),"^",18),TYPE=$P(^(0),"^",17)
- .S PRCSAPP=PRCSAPP-AMT,FIRST=FIRST-AMT,FINAL=FINAL-AMT
- .S Y=$P(REF,".") D DD^%DT W !,Y
- .W ?13,OBL,?24,TYPE,?32,$J(AMT,0,2),?42,$J(PRCSAPP,0,2),?54,$J(FIRST,0,2)
- .W ?68,$J(FINAL,0,2)
- .S FMSTOT=FMSTOT+AMT
- I FMSTOT<0 S MINUS="-",FMSTOT=-FMSTOT
- I Z1'=U W !!,"FMS transaction total for this quarter: ",MINUS,"$"_$J(FMSTOT,0,2)
- S L="",$P(L,"=",IOM)="=" W !,L S L=""
- S PRCS("PRE")=PRCSAPP,PRCS("C")=FIRST,PRCS("O")=FINAL Q
- HOLD1 ;
- Q:$D(C1)
- G HDR1:$D(ZTQUEUED),HDR1:IO'=IO(0) W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U D:Z1'=U HDR1 Q
- HDR1 ;
- S P1=1
- S P=P+1 W @IOF W "QUARTERLY REPORT "_"- "_Z(0)_" "_$E($P(PRC("CP")," ",2),1,10),?50,RDATE1,?73,"PAGE ",P
- W !,?40,"FMS Transactions",!
- W !,"TRANS",?32,"TRANS",?42,"CONTROL PT.",?54,"UNCOMMITTED",?68,"UNOBLIGATED",!,"DATE",?13,"REF #",?24,"TYPE",?32,"AMOUNT",?42,"REQ TOT",?54,"BALANCE",?68,"BALANCE"
- S L="",$P(L,"=",IOM)="=" W !,L S L="" Q
- NONE ; find PO with no 2237 for running balance
- N PRCSAPP,P1,Y,RDATE,TOTAL,AMT,AMT1,PI,REC,FIRST,FINAL,NET,STRING,NONNET
- N YEAR,L,RDATE1,CP,LINE,MINUS,TYPR,RQTR
- D NOW^%DTC S Y=% D DD^%DT S RDATE1=Y
- S CP=$P(PRC("CP")," "),REC="",TOTAL=0,P1=0,Z1=""
- S STRING="2^2^2^3^3^3^4^4^4^1^1^1"
- S:'$D(PRCS("O")) PRCS("O")=0 S FINAL=PRCS("O")
- S:'$D(PRCS("PRE")) PRCS("PRE")=0 S PRCSAPP=PRCS("PRE")
- S MINUS="" S:'$D(PRCS("C")) PRCS("C")=0 S FIRST=PRCS("C")
- S PRCC=+$$YEAR^PRC0C(PRC("FY"))
- S PRCE=$$QTRDATE^PRC0D(PRCC,PRC("QTR"))
- S REC=$P(PRCE,"^",8)+100,REC=$$DATE^PRC0C(REC,"H")
- S PRCG=$$QTRDATE^PRC0D(+REC,$P(REC,"^",2))
- S PRCE=$P(PRCE,"^",7)-1,PRCG=$P(PRCG,"^",7)-1
- F S PRCE=$O(^PRC(442,"AB",PRCE)) QUIT:PRCE>PRCG!'PRCE D Q:Z1=U
- . S REC=0 F S REC=$O(^PRC(442,"AB",PRCE,REC)) QUIT:'REC S PRCF=$G(^PRC(442,REC,0)) I $P(PRCF,"^",12)="",+PRCF=PRC("SITE"),+$P(PRCF,"^",3)=+PRC("CP") D:$P($G(^(12)),"^",2)]"" Q:Z1=U
- ..S AMT=$P($G(^PRC(442,REC,0)),"^",16) S:AMT="" AMT=0
- ..S:$P($G(^PRC(442,REC,7)),"^",2)=45 AMT=0
- ..I $P($G(^PRC(442,REC,0)),"^",2)=25,$P($G(^PRC(442,REC,7)),"^",2)=22 S AMT=0
- ..S PRCSAPP=PRCSAPP-AMT,FIRST=FIRST-AMT,FINAL=FINAL-AMT,TOTAL=TOTAL+AMT
- ..D:P1=0 HDR2
- ..W !,$P(^PRC(442,REC,0),"^")
- ..S Y=$P(^PRC(442,REC,1),"^",15) D DD^%DT W ?15,Y
- ..W ?30,$J(AMT,0,2),?41,$J(PRCSAPP,0,2),?55,$J(FIRST,0,2),?69,$J(FINAL,0,2)
- ..Q:Z1=U I IOSL-$Y<8 D HOLD2 Q:Z1=U
- .. QUIT
- . QUIT
- S PRCS("C")=FIRST,PRCS("O")=FINAL,PRCS("PRE")=PRCSAPP
- I TOTAL<0 S MINUS="-",TOTAL=-TOTAL
- I Z1'=U W !!,"PO transaction (no 2237) total for this quarter: ",MINUS,"$",$J(TOTAL,0,2)
- S L="",$P(L,"=",IOM)="=" W !,L S L="" QUIT
- HOLD2 ;
- Q:$D(C1)
- G HDR2:$D(ZTQUEUED),HDR2:IO'=IO(0) W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U D:Z1'=U HDR2 Q
- HDR2 ;
- S P1=1
- S P=P+1 W @IOF W "QUARTERLY REPORT "_Z(0)_" "_$E($P(PRC("CP")," ",2),1,10),?50,RDATE1,?73,"PAGE ",P
- W !,?5,"__________PO TRANSACTIONS WITHOUT 2237______________",!
- W !,"PO/",?15,"PO ",?30,"OBLIGATED",?41,"CONTROL PT.",?55,"UNCOMMITTED",?69,"UNOBLIGATED",!,"OBL#",?15,"DATE",?30,"AMOUNT",?42,"REQ TOT",?55,"BALANCE",?69,"BALANCE"
- S L="",$P(L,"=",IOM)="=" W !,L S L="" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSFMS1 4029 printed Feb 18, 2025@23:44:11 Page 2
- PRCSFMS1 ;WISC/KMB-FMS TRANSACTIONS FOR CP QUARTERLY REPORT ;10-17-94 11:05
- V ;;5.1;IFCAP;**90**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- BEGIN ; this routine is called from PRCSQR
- +1 ; find FMS transactions, for selected quarter, for CP
- +2 NEW Z1,FMSTOT,LINE,STRING,RDATE1,FIRST,FINAL,AMT,TYPE,MINUS,OBL,REF,RECNO,P1,PRCSAPP
- SET (P1,Z1)=0
- +3 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET RDATE1=Y
- +4 SET FMSTOT=0
- if '$DATA(PRCS("O"))
- SET PRCS("O")=0
- SET FINAL=PRCS("O")
- SET STRING=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_+PRC("CP")
- +5 if '$DATA(PRCS("PRE"))
- SET PRCS("PRE")=0
- SET PRCSAPP=PRCS("PRE")
- +6 SET MINUS=""
- if '$DATA(PRCS("C"))
- SET PRCS("C")=0
- SET FIRST=PRCS("C")
- +7 SET RECNO=""
- FOR
- SET RECNO=$ORDER(^PRCS(417,"C",STRING,RECNO))
- if RECNO=""
- QUIT
- Begin DoDot:1
- +8 IF P1=0
- DO HDR1
- +9 IF IOSL-$Y<8
- DO HOLD1
- if Z1=U
- QUIT
- +10 SET AMT=$PIECE(^PRCS(417,RECNO,0),"^",20)
- SET REF=$PIECE(^(0),"^",22)
- SET OBL=$PIECE(^(0),"^",18)
- SET TYPE=$PIECE(^(0),"^",17)
- +11 SET PRCSAPP=PRCSAPP-AMT
- SET FIRST=FIRST-AMT
- SET FINAL=FINAL-AMT
- +12 SET Y=$PIECE(REF,".")
- DO DD^%DT
- WRITE !,Y
- +13 WRITE ?13,OBL,?24,TYPE,?32,$JUSTIFY(AMT,0,2),?42,$JUSTIFY(PRCSAPP,0,2),?54,$JUSTIFY(FIRST,0,2)
- +14 WRITE ?68,$JUSTIFY(FINAL,0,2)
- +15 SET FMSTOT=FMSTOT+AMT
- End DoDot:1
- if Z1=U
- QUIT
- +16 IF FMSTOT<0
- SET MINUS="-"
- SET FMSTOT=-FMSTOT
- +17 IF Z1'=U
- WRITE !!,"FMS transaction total for this quarter: ",MINUS,"$"_$JUSTIFY(FMSTOT,0,2)
- +18 SET L=""
- SET $PIECE(L,"=",IOM)="="
- WRITE !,L
- SET L=""
- +19 SET PRCS("PRE")=PRCSAPP
- SET PRCS("C")=FIRST
- SET PRCS("O")=FINAL
- QUIT
- HOLD1 ;
- +1 if $DATA(C1)
- QUIT
- +2 if $DATA(ZTQUEUED)
- GOTO HDR1
- if IO'=IO(0)
- GOTO HDR1
- WRITE !,"Press return to continue, uparrow (^) to exit: "
- READ Z1:DTIME
- if '$TEST
- SET Z1=U
- if Z1'=U
- DO HDR1
- QUIT
- HDR1 ;
- +1 SET P1=1
- +2 SET P=P+1
- WRITE @IOF
- WRITE "QUARTERLY REPORT "_"- "_Z(0)_" "_$EXTRACT($PIECE(PRC("CP")," ",2),1,10),?50,RDATE1,?73,"PAGE ",P
- +3 WRITE !,?40,"FMS Transactions",!
- +4 WRITE !,"TRANS",?32,"TRANS",?42,"CONTROL PT.",?54,"UNCOMMITTED",?68,"UNOBLIGATED",!,"DATE",?13,"REF #",?24,"TYPE",?32,"AMOUNT",?42,"REQ TOT",?54,"BALANCE",?68,"BALANCE"
- +5 SET L=""
- SET $PIECE(L,"=",IOM)="="
- WRITE !,L
- SET L=""
- QUIT
- NONE ; find PO with no 2237 for running balance
- +1 NEW PRCSAPP,P1,Y,RDATE,TOTAL,AMT,AMT1,PI,REC,FIRST,FINAL,NET,STRING,NONNET
- +2 NEW YEAR,L,RDATE1,CP,LINE,MINUS,TYPR,RQTR
- +3 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET RDATE1=Y
- +4 SET CP=$PIECE(PRC("CP")," ")
- SET REC=""
- SET TOTAL=0
- SET P1=0
- SET Z1=""
- +5 SET STRING="2^2^2^3^3^3^4^4^4^1^1^1"
- +6 if '$DATA(PRCS("O"))
- SET PRCS("O")=0
- SET FINAL=PRCS("O")
- +7 if '$DATA(PRCS("PRE"))
- SET PRCS("PRE")=0
- SET PRCSAPP=PRCS("PRE")
- +8 SET MINUS=""
- if '$DATA(PRCS("C"))
- SET PRCS("C")=0
- SET FIRST=PRCS("C")
- +9 SET PRCC=+$$YEAR^PRC0C(PRC("FY"))
- +10 SET PRCE=$$QTRDATE^PRC0D(PRCC,PRC("QTR"))
- +11 SET REC=$PIECE(PRCE,"^",8)+100
- SET REC=$$DATE^PRC0C(REC,"H")
- +12 SET PRCG=$$QTRDATE^PRC0D(+REC,$PIECE(REC,"^",2))
- +13 SET PRCE=$PIECE(PRCE,"^",7)-1
- SET PRCG=$PIECE(PRCG,"^",7)-1
- +14 FOR
- SET PRCE=$ORDER(^PRC(442,"AB",PRCE))
- if PRCE>PRCG!'PRCE
- QUIT
- Begin DoDot:1
- +15 SET REC=0
- FOR
- SET REC=$ORDER(^PRC(442,"AB",PRCE,REC))
- if 'REC
- QUIT
- SET PRCF=$GET(^PRC(442,REC,0))
- IF $PIECE(PRCF,"^",12)=""
- IF +PRCF=PRC("SITE")
- IF +$PIECE(PRCF,"^",3)=+PRC("CP")
- if $PIECE($GET(^(12)),"^",2)]""
- Begin DoDot:2
- +16 SET AMT=$PIECE($GET(^PRC(442,REC,0)),"^",16)
- if AMT=""
- SET AMT=0
- +17 if $PIECE($GET(^PRC(442,REC,7)),"^",2)=45
- SET AMT=0
- +18 IF $PIECE($GET(^PRC(442,REC,0)),"^",2)=25
- IF $PIECE($GET(^PRC(442,REC,7)),"^",2)=22
- SET AMT=0
- +19 SET PRCSAPP=PRCSAPP-AMT
- SET FIRST=FIRST-AMT
- SET FINAL=FINAL-AMT
- SET TOTAL=TOTAL+AMT
- +20 if P1=0
- DO HDR2
- +21 WRITE !,$PIECE(^PRC(442,REC,0),"^")
- +22 SET Y=$PIECE(^PRC(442,REC,1),"^",15)
- DO DD^%DT
- WRITE ?15,Y
- +23 WRITE ?30,$JUSTIFY(AMT,0,2),?41,$JUSTIFY(PRCSAPP,0,2),?55,$JUSTIFY(FIRST,0,2),?69,$JUSTIFY(FINAL,0,2)
- +24 if Z1=U
- QUIT
- IF IOSL-$Y<8
- DO HOLD2
- if Z1=U
- QUIT
- +25 QUIT
- End DoDot:2
- if Z1=U
- QUIT
- +26 QUIT
- End DoDot:1
- if Z1=U
- QUIT
- +27 SET PRCS("C")=FIRST
- SET PRCS("O")=FINAL
- SET PRCS("PRE")=PRCSAPP
- +28 IF TOTAL<0
- SET MINUS="-"
- SET TOTAL=-TOTAL
- +29 IF Z1'=U
- WRITE !!,"PO transaction (no 2237) total for this quarter: ",MINUS,"$",$JUSTIFY(TOTAL,0,2)
- +30 SET L=""
- SET $PIECE(L,"=",IOM)="="
- WRITE !,L
- SET L=""
- QUIT
- HOLD2 ;
- +1 if $DATA(C1)
- QUIT
- +2 if $DATA(ZTQUEUED)
- GOTO HDR2
- if IO'=IO(0)
- GOTO HDR2
- WRITE !,"Press return to continue, uparrow (^) to exit: "
- READ Z1:DTIME
- if '$TEST
- SET Z1=U
- if Z1'=U
- DO HDR2
- QUIT
- HDR2 ;
- +1 SET P1=1
- +2 SET P=P+1
- WRITE @IOF
- WRITE "QUARTERLY REPORT "_Z(0)_" "_$EXTRACT($PIECE(PRC("CP")," ",2),1,10),?50,RDATE1,?73,"PAGE ",P
- +3 WRITE !,?5,"__________PO TRANSACTIONS WITHOUT 2237______________",!
- +4 WRITE !,"PO/",?15,"PO ",?30,"OBLIGATED",?41,"CONTROL PT.",?55,"UNCOMMITTED",?69,"UNOBLIGATED",!,"OBL#",?15,"DATE",?30,"AMOUNT",?42,"REQ TOT",?55,"BALANCE",?69,"BALANCE"
- +5 SET L=""
- SET $PIECE(L,"=",IOM)="="
- WRITE !,L
- SET L=""
- QUIT
