- PRCOE4 ;WISC/DJM-IFCAP SEGMENTS AC ;7/28/96 16:17
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- AC(A,A1,VAR1,VAR2) ;ACCOUNTING INFORMATION SEGMENT
- N A23,B,D,DDS,DIS,E,ES,FOB,G,GBL,NET,PC,Q,X,X1,X2,X2D,X2M,X2Y
- S FOB=$S($P(A1,U,6)]"":$P(A1,U,6),1:"D")
- S B="AC^^"_FOB_"^^"
- ;
- S ES=$P(A,U,13),ES=$$VDEC^PRCOEDI(ES,2)
- S GBL=$G(^PRC(442,VAR1,12))
- I FOB="O",$P(GBL,U,7)="" S $P(B,U,2)=ES
- ;
- S Q=$P($G(^PRC(442,VAR1,5,0)),U,4)
- I Q'>0 S B=B_"^30^N^" G AC1
- ;
- S A23=$G(^PRC(442,VAR1,23))
- I $P(A23,U,11)'="P",+A1>0,Q'>0 I $D(^PRC(440,+A1,3)),$P(^(3),U,2)="Y" S VAR2="NPPT" Q
- S (D,E)=""
- F S D=$O(^PRC(442,VAR1,5,D)) Q:D="" D
- . S DIS(D)=$G(^PRC(442,VAR1,5,D,0))
- . I +$P(DIS(D),U)=$P(DIS(D),U) S E=$S(E]"":E_"^"_D,1:D)
- I E]"" D G AC1
- . S G=$P(E,U),PC=$P(DIS(G),U)*100
- . S:$L(PC)=1 PC="0"_PC
- . S B=B_PC_"^"
- . D AC2
- . S B=B_DDS_"^^"
- ;
- S B=B_"^" D AC2 S B=B_DDS_"^N^"
- ;
- AC1 S NET=$P(A,U,16)
- I NET=""!($P($G(^PRC(442,VAR1,7)),"^",1)+0=45) S NET=0
- S NET=$TR($J(NET,10,2)," .","0")
- S B=B_NET_"^"_$E($P($P(A,U,4),"."),4,99)_"^^^"_$P(A,U,5)_"^"_$P($P(A,U,3)," ")_"^^^^^^|"
- S ^TMP($J,"STRING",6)=B
- Q
- ;
- AC2 I E]"" S DDS=DIS(G)
- I E="" S DDS=$O(DIS(0)),DDS=DIS(DDS)
- S DDS=$P(DDS,U,2) S:DDS="" DDS=30 Q:+DDS=DDS
- I '$G(DT) D NOW^%DTC K %,%I,%H
- S DDS=+DDS
- S X2=$S($G(DT):DT,1:X),X2Y=$E(X2,1,3),X2M=$E(X2,4,5),X2D=$E(X2,6,7)
- I DDS>X2D S X1=X2Y_X2M_DDS G AC3
- S X2M=X2M+1 S:X2M>12 X2M=1,X2Y=X2Y+1 S X1=X2Y_X2M_DDS
- AC3 D ^%DTC S DDS=X K %Y,X Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOE4 1551 printed Feb 18, 2025@23:38:08 Page 2
- PRCOE4 ;WISC/DJM-IFCAP SEGMENTS AC ;7/28/96 16:17
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- AC(A,A1,VAR1,VAR2) ;ACCOUNTING INFORMATION SEGMENT
- +1 NEW A23,B,D,DDS,DIS,E,ES,FOB,G,GBL,NET,PC,Q,X,X1,X2,X2D,X2M,X2Y
- +2 SET FOB=$SELECT($PIECE(A1,U,6)]"":$PIECE(A1,U,6),1:"D")
- +3 SET B="AC^^"_FOB_"^^"
- +4 ;
- +5 SET ES=$PIECE(A,U,13)
- SET ES=$$VDEC^PRCOEDI(ES,2)
- +6 SET GBL=$GET(^PRC(442,VAR1,12))
- +7 IF FOB="O"
- IF $PIECE(GBL,U,7)=""
- SET $PIECE(B,U,2)=ES
- +8 ;
- +9 SET Q=$PIECE($GET(^PRC(442,VAR1,5,0)),U,4)
- +10 IF Q'>0
- SET B=B_"^30^N^"
- GOTO AC1
- +11 ;
- +12 SET A23=$GET(^PRC(442,VAR1,23))
- +13 IF $PIECE(A23,U,11)'="P"
- IF +A1>0
- IF Q'>0
- IF $DATA(^PRC(440,+A1,3))
- IF $PIECE(^(3),U,2)="Y"
- SET VAR2="NPPT"
- QUIT
- +14 SET (D,E)=""
- +15 FOR
- SET D=$ORDER(^PRC(442,VAR1,5,D))
- if D=""
- QUIT
- Begin DoDot:1
- +16 SET DIS(D)=$GET(^PRC(442,VAR1,5,D,0))
- +17 IF +$PIECE(DIS(D),U)=$PIECE(DIS(D),U)
- SET E=$SELECT(E]"":E_"^"_D,1:D)
- End DoDot:1
- +18 IF E]""
- Begin DoDot:1
- +19 SET G=$PIECE(E,U)
- SET PC=$PIECE(DIS(G),U)*100
- +20 if $LENGTH(PC)=1
- SET PC="0"_PC
- +21 SET B=B_PC_"^"
- +22 DO AC2
- +23 SET B=B_DDS_"^^"
- End DoDot:1
- GOTO AC1
- +24 ;
- +25 SET B=B_"^"
- DO AC2
- SET B=B_DDS_"^N^"
- +26 ;
- AC1 SET NET=$PIECE(A,U,16)
- +1 IF NET=""!($PIECE($GET(^PRC(442,VAR1,7)),"^",1)+0=45)
- SET NET=0
- +2 SET NET=$TRANSLATE($JUSTIFY(NET,10,2)," .","0")
- +3 SET B=B_NET_"^"_$EXTRACT($PIECE($PIECE(A,U,4),"."),4,99)_"^^^"_$PIECE(A,U,5)_"^"_$PIECE($PIECE(A,U,3)," ")_"^^^^^^|"
- +4 SET ^TMP($JOB,"STRING",6)=B
- +5 QUIT
- +6 ;
- AC2 IF E]""
- SET DDS=DIS(G)
- +1 IF E=""
- SET DDS=$ORDER(DIS(0))
- SET DDS=DIS(DDS)
- +2 SET DDS=$PIECE(DDS,U,2)
- if DDS=""
- SET DDS=30
- if +DDS=DDS
- QUIT
- +3 IF '$GET(DT)
- DO NOW^%DTC
- KILL %,%I,%H
- +4 SET DDS=+DDS
- +5 SET X2=$SELECT($GET(DT):DT,1:X)
- SET X2Y=$EXTRACT(X2,1,3)
- SET X2M=$EXTRACT(X2,4,5)
- SET X2D=$EXTRACT(X2,6,7)
- +6 IF DDS>X2D
- SET X1=X2Y_X2M_DDS
- GOTO AC3
- +7 SET X2M=X2M+1
- if X2M>12
- SET X2M=1
- SET X2Y=X2Y+1
- SET X1=X2Y_X2M_DDS
- AC3 DO ^%DTC
- SET DDS=X
- KILL %Y,X
- QUIT
