- PRCS58OB ;WISC/CLH-OBLIGATION PROCESSING ;07/21/93
- V ;;5.1;IFCAP;**148,150,176**;Oct 20, 2000;Build 11
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
- ;kill call since DIK call does not handle descending file logic
- ;
- OB(DA) ;Obligation edits
- SC N DIE,DR
- S DIE="^PRCS(410,",DIE("NO^")=""
- S DR="15.5;S NEWCC=X;W !;17;S NEWBOC=X" D ^DIE
- ;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
- Q
- OB1(OB,DA) ;set obligation number in 410
- N DIE,DR,Z
- S Z=DA,DA=OB,DIE="^PRCS(410,",DR="52///^S X=Z" D ^DIE
- Q
- CS(OB,AMT,TIME,PATNUM,PODA,DEL,X,PRC) ;set code sheet information in 410
- N Y
- ; Change ESIG processing:
- 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
- S MESSAGE=""
- D ENCODE^PRCSC2(OB,DUZ,.MESSAGE)
- K MESSAGE
- S $P(^PRCS(410,OB,10),"^",3,4)=PODA_"^" S:$D(DEL) $P(^(9),"^",2)=DEL S ^PRCS(410,"D",$P(PATNUM,"-",2),OB)=""
- Q
- ;End of first ESIG mod for this routine . . .
- PODT(DA,A) ; post P.O. Date onto 442 record
- N DIE,DR
- S DIE="^PRC(442,",DR=".1////"_A D ^DIE
- Q
- ADJ(DIC,DA,PRCSIP,X4) ;enter adjustment on transaction
- N DIE,DR
- S DIC(0)="AEMQ",DIE=DIC,DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:""),X4=1 D ^DIE
- Q
- ADJ1(DA,X,Y) N DIE,DR,Z
- 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
- Q
- ADJ2(PRC,X,DA) ;mark the transaction as an adjustment
- N PRCX442 S PRCX442=X,PRCX442=$$UPPER^PRCFFU5(PRCX442) D OBL^PRCSES2 S X=PRCX442
- N X1,X2
- ENA2 S DIC(0)="AEMQ",DIE="^PRCS(410,",DR="[PRCE 1358 ADJUSTMENT]" D ^DIE
- I $D(Y)#10 D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No") I Y=1 D QUIT:X=1
- . S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150
- . D DELETE^PRC0B1(.X,"410;^PRCS(410,;"_DA)
- . I X=1 S $P(^PRCS(410,0),"^",3)=PRCIENCT ;PRC*5.1*150
- . K PRCIENCT ;PRC*5.1*150
- . D EN^DDIOL(" **** NEW ENTRY IS "_$S(X=1:"",1:"NOT ")_"DELETED ****")
- . QUIT
- I DA S X=$P($G(^PRCS(410,DA,4)),U,6) D:X TRANK^PRCSEZ
- I $G(PRC410),$G(PRC442),$$EN1^PRCE0A(PRC410,PRC442,1) G ENA2
- I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)>0 G ENA3
- 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
- ENA3 D:$O(^PRCS(410,DA,12,0)) SCPC0^PRCSED D W1^PRCSEB I $D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB
- Q
- NODE(DA,TRNODE) ;get transaction node information from 410
- K TRNODE F I=0,1,2,3,4,7,10,11,14 S TRNODE(I)="" S:$D(^PRCS(410,DA,I)) TRNODE(I)=^(I)
- S:$P(TRNODE(3),"^",11)="" $P(TRNODE(3),"^",11)=$P(TRNODE(0),"-",2)+200_"0000"
- S I=0 F S I=$O(^PRCS(410,DA,8,I)) Q:'I S:$D(^(I,0)) TRNODE(8,I)=^(0)
- Q
- LU(Y,PRC,PRCF) N DIC,FSO,PRCFA,PX
- ;look up transaction
- N PRCLOCK
- F D Q:$G(PRCLOCK) W !!,"***The Transaction Number you are attempting to access is being accessed by another user***",!! ;Only allow one user to access 410 record at a time, PRC*5.1*176
- .S DIC=410,DIC(0)="AEMNZ"
- .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"
- .D ^PRCSDIC
- .I Y>0 L +^PRCS(410,+Y):$G(DILOCKTM,3) S PRCLOCK=$T
- .I Y<1 S PRCLOCK=$T
- Q
- SAEDIT(PO,DA) N DIE,DR
- I '$D(PRCFA("TRDA")),$G(DA)]"" S PRCFA("TRDA")=$G(DA)
- W !!,"The current values are:",!,?10,"BOC #1: ",$P(PO(0),"^",6),!?10,"BOC #2:",$P(PO(0),"^",8),!!,"Please enter the corrected values.",!!
- S DA=PRCFA("TRDA"),DIE="^PRCS(410,",DR="17;18" D ^DIE S TRNODE(3)=^PRCS(410,DA,3)
- Q
- POADJ(PRC,PODA,TRDA,AMT) ;set adjustments obligations in 410
- ;This code modified for new ESIG:
- N DA,TIME,X
- S DA=TRDA
- D NOW^PRCFQ S TIME=X K %,%X
- S $P(^PRCS(410,DA,10),U,3,4)=PRCFA("PODA")_U
- 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
- S MESSAGE=""
- D ENCODE^PRCSC2(DA,DUZ,.MESSAGE)
- K MESSAGE
- S PRCHOBL="" D TRANK^PRCSES,TRANS^PRCSES K PRCHOBL D TRANS1^PRCSES
- Q
- ;End of ESIG mods.
- OROBL(DIC,PRC,DA) ;lookup obligation number on original 1358 request
- 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)"
- D IX^DIC
- I X=" " D
- .N TRDAIEN
- .S TRDAIEN=Y,%X="Y(",%Y="TRDAIEN(" D %XY^%RCR K %X,%Y
- .K PRCTMP(410,+TRDAIEN,52)
- .D GENDIQ^PRCFFU7(410,+TRDAIEN,52,"IEN","")
- .S X=$P($G(PRCTMP(410,+TRDAIEN,52,"E")),"-",2)
- .K PRCTMP(410,+TRDAIEN,52)
- .S Y=TRDAIEN,%X="TRDAIEN(",%Y="Y(" D %XY^%RCR K %X,%Y
- .Q
- Q
- RTN(DA) ;return request to service
- N DIE,DR,AMT,X
- S DIE="^PRCS(410,",DR="61" D ^DIE I $D(Y) S X="No action taken*" D MSG^PRCFQ Q
- 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))
- Q
- KILL(TRDA) ;kill obligation transaction when obligation data killed
- S $P(^PRCS(410,TRDA,10),"^",4)=$O(^PRCD(442.3,"AC",10,0))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCS58OB 5296 printed Feb 18, 2025@23:43:31 Page 2
- PRCS58OB ;WISC/CLH-OBLIGATION PROCESSING ;07/21/93
- V ;;5.1;IFCAP;**148,150,176**;Oct 20, 2000;Build 11
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;
- +3 ;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
- +4 ;kill call since DIK call does not handle descending file logic
- +5 ;
- OB(DA) ;Obligation edits
- SC NEW DIE,DR
- +1 SET DIE="^PRCS(410,"
- SET DIE("NO^")=""
- +2 SET DR="15.5;S NEWCC=X;W !;17;S NEWBOC=X"
- DO ^DIE
- +3 ;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
- +4 QUIT
- OB1(OB,DA) ;set obligation number in 410
- +1 NEW DIE,DR,Z
- +2 SET Z=DA
- SET DA=OB
- SET DIE="^PRCS(410,"
- SET DR="52///^S X=Z"
- DO ^DIE
- +3 QUIT
- CS(OB,AMT,TIME,PATNUM,PODA,DEL,X,PRC) ;set code sheet information in 410
- +1 NEW Y
- +2 ; Change ESIG processing:
- +3 SET Y=$SELECT($DATA(^PRCS(410,OB,4)):^(4),1:"")
- SET $PIECE(Y,"^",3,5)=AMT_"^"_TIME_"^"_$PIECE(PATNUM,"-",2)
- SET $PIECE(Y,"^",8)=AMT
- SET ^(4)=Y
- +4 SET MESSAGE=""
- +5 DO ENCODE^PRCSC2(OB,DUZ,.MESSAGE)
- +6 KILL MESSAGE
- +7 SET $PIECE(^PRCS(410,OB,10),"^",3,4)=PODA_"^"
- if $DATA(DEL)
- SET $PIECE(^(9),"^",2)=DEL
- SET ^PRCS(410,"D",$PIECE(PATNUM,"-",2),OB)=""
- +8 QUIT
- +9 ;End of first ESIG mod for this routine . . .
- PODT(DA,A) ; post P.O. Date onto 442 record
- +1 NEW DIE,DR
- +2 SET DIE="^PRC(442,"
- SET DR=".1////"_A
- DO ^DIE
- +3 QUIT
- ADJ(DIC,DA,PRCSIP,X4) ;enter adjustment on transaction
- +1 NEW DIE,DR
- +2 SET DIC(0)="AEMQ"
- SET DIE=DIC
- SET DR="3///1"_$SELECT($DATA(PRCSIP):";4////"_PRCSIP,1:"")
- SET X4=1
- DO ^DIE
- +3 QUIT
- ADJ1(DA,X,Y) NEW DIE,DR,Z
- +1 SET Z=Y
- SET DIE="^PRCS(410,"
- SET DR="1///^S X=""A"";3///^S X=1;24///^S X=$P(^PRCS(410,+Z,4),U,5);52////^S X=$G(PRC442)"
- DO ^DIE
- +2 QUIT
- ADJ2(PRC,X,DA) ;mark the transaction as an adjustment
- +1 NEW PRCX442
- SET PRCX442=X
- SET PRCX442=$$UPPER^PRCFFU5(PRCX442)
- DO OBL^PRCSES2
- SET X=PRCX442
- +2 NEW X1,X2
- ENA2 SET DIC(0)="AEMQ"
- SET DIE="^PRCS(410,"
- SET DR="[PRCE 1358 ADJUSTMENT]"
- DO ^DIE
- +1 IF $DATA(Y)#10
- DO YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
- IF Y=1
- Begin DoDot:1
- +2 ;PRC*5.1*150
- SET PRCIENCT=$PIECE(^PRCS(410,0),"^",3)+1
- +3 DO DELETE^PRC0B1(.X,"410;^PRCS(410,;"_DA)
- +4 ;PRC*5.1*150
- IF X=1
- SET $PIECE(^PRCS(410,0),"^",3)=PRCIENCT
- +5 ;PRC*5.1*150
- KILL PRCIENCT
- +6 DO EN^DDIOL(" **** NEW ENTRY IS "_$SELECT(X=1:"",1:"NOT ")_"DELETED ****")
- +7 QUIT
- End DoDot:1
- if X=1
- QUIT
- +8 IF DA
- SET X=$PIECE($GET(^PRCS(410,DA,4)),U,6)
- if X
- DO TRANK^PRCSEZ
- +9 IF $GET(PRC410)
- IF $GET(PRC442)
- IF $$EN1^PRCE0A(PRC410,PRC442,1)
- GOTO ENA2
- +10 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
- IF $PIECE(^(0),U,12)>0
- GOTO ENA3
- +11 IF $DATA(^PRCS(410,DA,4))
- SET X=$PIECE(^(4),U,6)
- SET X2=^(3)
- SET X1=$PIECE(X2,U,7)+$PIECE(X2,U,9)
- IF $JUSTIFY(X,0,2)'=$JUSTIFY(X1,0,2)!('X)!('X1)
- WRITE $CHAR(7),!,"Adjustment $ Amount does not equal the BOC $ Amount.",!,"Please correct the error.",!
- GOTO ENA2
- ENA3 if $ORDER(^PRCS(410,DA,12,0))
- DO SCPC0^PRCSED
- DO W1^PRCSEB
- IF $DATA(PRCS2)
- IF +^PRCS(410,DA,0)
- DO W6^PRCSEB
- +1 QUIT
- NODE(DA,TRNODE) ;get transaction node information from 410
- +1 KILL TRNODE
- FOR I=0,1,2,3,4,7,10,11,14
- SET TRNODE(I)=""
- if $DATA(^PRCS(410,DA,I))
- SET TRNODE(I)=^(I)
- +2 if $PIECE(TRNODE(3),"^",11)=""
- SET $PIECE(TRNODE(3),"^",11)=$PIECE(TRNODE(0),"-",2)+200_"0000"
- +3 SET I=0
- FOR
- SET I=$ORDER(^PRCS(410,DA,8,I))
- if 'I
- QUIT
- if $DATA(^(I,0))
- SET TRNODE(8,I)=^(0)
- +4 QUIT
- LU(Y,PRC,PRCF) NEW DIC,FSO,PRCFA,PX
- +1 ;look up transaction
- +2 NEW PRCLOCK
- +3 ;Only allow one user to access 410 record at a time, PRC*5.1*176
- FOR
- Begin DoDot:1
- +4 SET DIC=410
- SET DIC(0)="AEMNZ"
- +5 SET PRCFA(1358)=""
- SET FSO=$ORDER(^PRCD(442.3,"AC",10,0))
- SET 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"
- +6 DO ^PRCSDIC
- +7 IF Y>0
- LOCK +^PRCS(410,+Y):$GET(DILOCKTM,3)
- SET PRCLOCK=$TEST
- +8 IF Y<1
- SET PRCLOCK=$TEST
- End DoDot:1
- if $GET(PRCLOCK)
- QUIT
- WRITE !!,"***The Transaction Number you are attempting to access is being accessed by another user***",!!
- +9 QUIT
- SAEDIT(PO,DA) NEW DIE,DR
- +1 IF '$DATA(PRCFA("TRDA"))
- IF $GET(DA)]""
- SET PRCFA("TRDA")=$GET(DA)
- +2 WRITE !!,"The current values are:",!,?10,"BOC #1: ",$PIECE(PO(0),"^",6),!?10,"BOC #2:",$PIECE(PO(0),"^",8),!!,"Please enter the corrected values.",!!
- +3 SET DA=PRCFA("TRDA")
- SET DIE="^PRCS(410,"
- SET DR="17;18"
- DO ^DIE
- SET TRNODE(3)=^PRCS(410,DA,3)
- +4 QUIT
- POADJ(PRC,PODA,TRDA,AMT) ;set adjustments obligations in 410
- +1 ;This code modified for new ESIG:
- +2 NEW DA,TIME,X
- +3 SET DA=TRDA
- +4 DO NOW^PRCFQ
- SET TIME=X
- KILL %,%X
- +5 SET $PIECE(^PRCS(410,DA,10),U,3,4)=PRCFA("PODA")_U
- +6 SET X=^PRCS(410,DA,4)
- SET $PIECE(X,"^",3,5)=AMT_"^"_TIME_"^"_$PIECE($PIECE(^PRC(442,PRCFA("PODA"),0),"^"),"-",2)
- SET $PIECE(X,"^",8)=AMT
- SET ^PRCS(410,DA,4)=X
- SET X=AMT
- +7 SET MESSAGE=""
- +8 DO ENCODE^PRCSC2(DA,DUZ,.MESSAGE)
- +9 KILL MESSAGE
- +10 SET PRCHOBL=""
- DO TRANK^PRCSES
- DO TRANS^PRCSES
- KILL PRCHOBL
- DO TRANS1^PRCSES
- +11 QUIT
- +12 ;End of ESIG mods.
- OROBL(DIC,PRC,DA) ;lookup obligation number on original 1358 request
- +1 SET DIC("A")="Select OBLIGATION NUMBER: "
- SET DIC(0)="AEQZ"
- SET D="D"
- SET DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,4)=1,PRC(""SITE"")=+^(0)"
- IF $DATA(PRC("CP"))
- SET DIC("S")=DIC("S")_",+PRC(""CP"")=+$P($P(^(0),U),""-"",4)"
- +2 DO IX^DIC
- +3 IF X=" "
- Begin DoDot:1
- +4 NEW TRDAIEN
- +5 SET TRDAIEN=Y
- SET %X="Y("
- SET %Y="TRDAIEN("
- DO %XY^%RCR
- KILL %X,%Y
- +6 KILL PRCTMP(410,+TRDAIEN,52)
- +7 DO GENDIQ^PRCFFU7(410,+TRDAIEN,52,"IEN","")
- +8 SET X=$PIECE($GET(PRCTMP(410,+TRDAIEN,52,"E")),"-",2)
- +9 KILL PRCTMP(410,+TRDAIEN,52)
- +10 SET Y=TRDAIEN
- SET %X="TRDAIEN("
- SET %Y="Y("
- DO %XY^%RCR
- KILL %X,%Y
- +11 QUIT
- End DoDot:1
- +12 QUIT
- RTN(DA) ;return request to service
- +1 NEW DIE,DR,AMT,X
- +2 SET DIE="^PRCS(410,"
- SET DR="61"
- DO ^DIE
- IF $DATA(Y)
- SET X="No action taken*"
- DO MSG^PRCFQ
- QUIT
- +3 SET AMT=$PIECE(^PRCS(410,DA,4),"^",8)
- SET X=AMT
- DO TRANK^PRCSES
- SET $PIECE(^PRCS(410,DA,7),"^",5,7)="^^"
- SET $PIECE(^PRCS(410,DA,10),"^",4)=$ORDER(^PRCD(442.3,"AC",9,0))
- +4 QUIT
- KILL(TRDA) ;kill obligation transaction when obligation data killed
- +1 SET $PIECE(^PRCS(410,TRDA,10),"^",4)=$ORDER(^PRCD(442.3,"AC",10,0))
- +2 QUIT