| [613] | 1 | PRCS58OB ;WISC/CLH-OBLIGATION PROCESSING ; 07/21/93 2:11 PM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | OB(DA) ;Obligation edits
|
|---|
| 5 | SC N DIE,DR
|
|---|
| 6 | S DIE="^PRCS(410,",DIE("NO^")=""
|
|---|
| 7 | S DR="15.5;S NEWCC=X;W !;17;S NEWBOC=X" D ^DIE
|
|---|
| 8 | ;S DR="15.5;W !;17;@1;S AMT=$P(^PRCS(410,DA,4),U);17.5;S S1AMT=X;W !;18;18.5;I X+S1AMT'=+AMT W !,$C(7),?5,""Amounts out of balance"" K AMT,S1AMT S Y=""@1""" D ^DIE
|
|---|
| 9 | Q
|
|---|
| 10 | OB1(OB,DA) ;set obligation number in 410
|
|---|
| 11 | N DIE,DR,Z
|
|---|
| 12 | S Z=DA,DA=OB,DIE="^PRCS(410,",DR="52///^S X=Z" D ^DIE
|
|---|
| 13 | Q
|
|---|
| 14 | CS(OB,AMT,TIME,PATNUM,PODA,DEL,X,PRC) ;set code sheet information in 410
|
|---|
| 15 | N Y
|
|---|
| 16 | ; Change ESIG processing:
|
|---|
| 17 | S Y=$S($D(^PRCS(410,OB,4)):^(4),1:""),$P(Y,"^",3,5)=AMT_"^"_TIME_"^"_$P(PATNUM,"-",2),$P(Y,"^",8)=AMT,^(4)=Y
|
|---|
| 18 | S MESSAGE=""
|
|---|
| 19 | D ENCODE^PRCSC2(OB,DUZ,.MESSAGE)
|
|---|
| 20 | K MESSAGE
|
|---|
| 21 | S $P(^PRCS(410,OB,10),"^",3,4)=PODA_"^" S:$D(DEL) $P(^(9),"^",2)=DEL S ^PRCS(410,"D",$P(PATNUM,"-",2),OB)=""
|
|---|
| 22 | Q
|
|---|
| 23 | ;End of first ESIG mod for this routine . . .
|
|---|
| 24 | PODT(DA,A) ; post P.O. Date onto 442 record
|
|---|
| 25 | N DIE,DR
|
|---|
| 26 | S DIE="^PRC(442,",DR=".1////"_A D ^DIE
|
|---|
| 27 | Q
|
|---|
| 28 | ADJ(DIC,DA,PRCSIP,X4) ;enter adjustment on transaction
|
|---|
| 29 | N DIE,DR
|
|---|
| 30 | S DIC(0)="AEMQ",DIE=DIC,DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:""),X4=1 D ^DIE
|
|---|
| 31 | Q
|
|---|
| 32 | ADJ1(DA,X,Y) N DIE,DR,Z
|
|---|
| 33 | S Z=Y,DIE="^PRCS(410,",DR="1///^S X=""A"";3///^S X=1;24///^S X=$P(^PRCS(410,+Z,4),U,5);52////^S X=$G(PRC442)" D ^DIE
|
|---|
| 34 | Q
|
|---|
| 35 | ADJ2(PRC,X,DA) ;mark the transaction as an adjustment
|
|---|
| 36 | N PRCX442 S PRCX442=X,PRCX442=$$UPPER^PRCFFU5(PRCX442) D OBL^PRCSES2 S X=PRCX442
|
|---|
| 37 | N X1,X2
|
|---|
| 38 | ENA2 S DIC(0)="AEMQ",DIE="^PRCS(410,",DR="[PRCE 1358 ADJUSTMENT]" D ^DIE
|
|---|
| 39 | I $D(Y)#10 D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No") I Y=1 D QUIT:X=1
|
|---|
| 40 | . D DELETE^PRC0B1(.X,"410;^PRCS(410,;"_DA)
|
|---|
| 41 | . D EN^DDIOL(" **** NEW ENTRY IS "_$S(X=1:"",1:"NOT ")_"DELETED ****")
|
|---|
| 42 | . QUIT
|
|---|
| 43 | I DA S X=$P($G(^PRCS(410,DA,4)),U,6) D:X TRANK^PRCSEZ
|
|---|
| 44 | I $G(PRC410),$G(PRC442),$$EN1^PRCE0A(PRC410,PRC442,1) G ENA2
|
|---|
| 45 | I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)>0 G ENA3
|
|---|
| 46 | I $D(^PRCS(410,DA,4)) S X=$P(^(4),U,6),X2=^(3),X1=$P(X2,U,7)+$P(X2,U,9) I $J(X,0,2)'=$J(X1,0,2)!('X)!('X1) W $C(7),!,"Adjustment $ Amount does not equal the BOC $ Amount.",!,"Please correct the error.",! G ENA2
|
|---|
| 47 | ENA3 D:$O(^PRCS(410,DA,12,0)) SCPC0^PRCSED D W1^PRCSEB I $D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB
|
|---|
| 48 | Q
|
|---|
| 49 | NODE(DA,TRNODE) ;get transaction node information from 410
|
|---|
| 50 | K TRNODE F I=0,1,2,3,4,7,10,14 S TRNODE(I)="" S:$D(^PRCS(410,DA,I)) TRNODE(I)=^(I)
|
|---|
| 51 | S:$P(TRNODE(3),"^",11)="" $P(TRNODE(3),"^",11)=$P(TRNODE(0),"-",2)+200_"0000"
|
|---|
| 52 | S I=0 F S I=$O(^PRCS(410,DA,8,I)) Q:'I S:$D(^(I,0)) TRNODE(8,I)=^(0)
|
|---|
| 53 | Q
|
|---|
| 54 | LU(Y,PRC,PRCF) N DIC,FSO,PRCFA,PX
|
|---|
| 55 | ;look up transaction
|
|---|
| 56 | S DIC=410,DIC(0)="AEMNZ"
|
|---|
| 57 | S PRCFA(1358)="",FSO=$O(^PRCD(442.3,"AC",10,0)),DIC("S")="S PX=^(0) I $P($P(PX,U),""-"",1,2)=PRCF(""SIFY""),$P(PX,U,4)=1,$D(^(10)),$P(^(10),U,4)=FSO"
|
|---|
| 58 | D ^PRCSDIC
|
|---|
| 59 | Q
|
|---|
| 60 | SAEDIT(PO,DA) N DIE,DR
|
|---|
| 61 | I '$D(PRCFA("TRDA")),$G(DA)]"" S PRCFA("TRDA")=$G(DA)
|
|---|
| 62 | W !!,"The current values are:",!,?10,"BOC #1: ",$P(PO(0),"^",6),!?10,"BOC #2:",$P(PO(0),"^",8),!!,"Please enter the corrected values.",!!
|
|---|
| 63 | S DA=PRCFA("TRDA"),DIE="^PRCS(410,",DR="17;18" D ^DIE S TRNODE(3)=^PRCS(410,DA,3)
|
|---|
| 64 | Q
|
|---|
| 65 | POADJ(PRC,PODA,TRDA,AMT) ;set adjustments obligations in 410
|
|---|
| 66 | ;This code modified for new ESIG:
|
|---|
| 67 | N DA,TIME,X
|
|---|
| 68 | S DA=TRDA
|
|---|
| 69 | D NOW^PRCFQ S TIME=X K %,%X
|
|---|
| 70 | S $P(^PRCS(410,DA,10),U,3,4)=PRCFA("PODA")_U
|
|---|
| 71 | S X=^PRCS(410,DA,4),$P(X,"^",3,5)=AMT_"^"_TIME_"^"_$P($P(^PRC(442,PRCFA("PODA"),0),"^"),"-",2),$P(X,"^",8)=AMT,^PRCS(410,DA,4)=X,X=AMT
|
|---|
| 72 | S MESSAGE=""
|
|---|
| 73 | D ENCODE^PRCSC2(DA,DUZ,.MESSAGE)
|
|---|
| 74 | K MESSAGE
|
|---|
| 75 | S PRCHOBL="" D TRANK^PRCSES,TRANS^PRCSES K PRCHOBL D TRANS1^PRCSES
|
|---|
| 76 | Q
|
|---|
| 77 | ;End of ESIG mods.
|
|---|
| 78 | OROBL(DIC,PRC,DA) ;lookup obligation number on original 1358 request
|
|---|
| 79 | S DIC("A")="Select OBLIGATION NUMBER: ",DIC(0)="AEQZ",D="D",DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,4)=1,PRC(""SITE"")=+^(0)" I $D(PRC("CP")) S DIC("S")=DIC("S")_",+PRC(""CP"")=+$P($P(^(0),U),""-"",4)"
|
|---|
| 80 | D IX^DIC
|
|---|
| 81 | I X=" " D
|
|---|
| 82 | .N TRDAIEN
|
|---|
| 83 | .S TRDAIEN=Y,%X="Y(",%Y="TRDAIEN(" D %XY^%RCR K %X,%Y
|
|---|
| 84 | .K PRCTMP(410,+TRDAIEN,52)
|
|---|
| 85 | .D GENDIQ^PRCFFU7(410,+TRDAIEN,52,"IEN","")
|
|---|
| 86 | .S X=$P($G(PRCTMP(410,+TRDAIEN,52,"E")),"-",2)
|
|---|
| 87 | .K PRCTMP(410,+TRDAIEN,52)
|
|---|
| 88 | .S Y=TRDAIEN,%X="TRDAIEN(",%Y="Y(" D %XY^%RCR K %X,%Y
|
|---|
| 89 | .Q
|
|---|
| 90 | Q
|
|---|
| 91 | RTN(DA) ;return request to service
|
|---|
| 92 | N DIE,DR,AMT,X
|
|---|
| 93 | S DIE="^PRCS(410,",DR="61" D ^DIE I $D(Y) S X="No action taken*" D MSG^PRCFQ Q
|
|---|
| 94 | S AMT=$P(^PRCS(410,DA,4),"^",8),X=AMT D TRANK^PRCSES S $P(^PRCS(410,DA,7),"^",5,7)="^^",$P(^PRCS(410,DA,10),"^",4)=$O(^PRCD(442.3,"AC",9,0))
|
|---|
| 95 | Q
|
|---|
| 96 | KILL(TRDA) ;kill obligation transaction when obligation data killed
|
|---|
| 97 | S $P(^PRCS(410,TRDA,10),"^",4)=$O(^PRCD(442.3,"AC",10,0))
|
|---|
| 98 | Q
|
|---|
