PRCH58OB ;WISC/CLH-OBLIGATE,ADJUST 1358 ;11/28/94 15:06
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
COB(DA,TRNODE,PO,OB,X) ;
;enter transaction information onto PO
;kills TMP("NEWDATE"),TMP("NEWACC")
N DATE,FLAG,I,J,PRCBBFY,SUBSTA,X
S $P(PO(0),"^",3,9)=$P(TRNODE(3),"^",1,3)_"^"_$P(TRNODE(3),"^",6,9)
S X=$P(PO(0),"^",7)+$P(PO(0),"^",9)
S $P(PO(0),"^",11,12)=X_"^"_OB
S $P(PO(0),"^",15)=$P(TRNODE(4),"^")
F I=6,8 S $P(PO(0),"^",I)=+$P(PO(0),"^",I)
S PO(1)=$P(TRNODE(3),"^",4,5)
;
L +^PRC(442,DA)
S ^PRC(442,DA,0)=PO(0)
S $P(^PRC(442,DA,1),"^",1,2)=$P(PO(1),"^",1,2)
S:$P(PO(0),"^",3)]"" ^PRC(442,"E",$P($P(PO(0),"^",3)," "),DA)=""
S:$P(PO(1),"^")]"" ^PRC(442,"D",$P(PO(1),"^"),DA)=""
I $D(PRCFA("RETRAN")),'PRCFA("RETRAN") D NODE22^PRCFFU5
S PRCBBFY=$P(TRNODE(3),U,11)
S SUBSTA=$P(TRNODE(0),"^",10)
S:'$D(TMP("NEWDATE")) TMP("NEWDATE")=""
S:'$D(TMP("NEWACC")) TMP("NEWACC")="0^NO"
S DATE=$P(TMP("NEWDATE"),U)
S FLAG=$P(TMP("NEWACC"),U)
S DIE=442
S DR="26///^S X=PRCBBFY;29///^S X=DATE;30///^S X=FLAG;31///^S X=SUBSTA"
D ^DIE
K DIE,DR
K TMP("NEWDATE")
K TMP("NEWACC")
I $P($G(^PRC(442,DA,12)),"^",2)]"" D
. D REMOVE^PRCHES5(DA),ENCODE^PRCHES5(DA,$P(^PRC(442,DA,1),"^",10))
. QUIT
L -^PRC(442,DA)
Q
;
PAT(DA,PODA,PO,PATNUM) ;get pat info, kill PRCHPO
S (PO,PODA)=DA
S PO(0)=$G(^PRC(442,PODA,0))
S PATNUM=$P(PO(0),U)
K PRCHPO
Q
;
ADJ(DIC,PRC,DA) ;
S DIC("A")="Select OBLIGATION NUMBER: "
S DIC(0)="AEQZ"
S D="D"
S DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,4)=1,PRC(""SITE"")=+^(0),+PRC(""CP"")=+$P($P(^(0),U),""-"",4)"
D IX^DIC
Q
;
VER(PRC,X) ;verify entry
S X=$O(^PRC(442,"B",PRC("SITE")_"-"_X,0))
Q
;
PO(DA,PO) ;PO data for adjustments
N I
F I=0,1,7,8 S PO(I)=$G(^PRC(442,DA,I))
Q
;
OLDTT(DA,X) ;old code sheet info
S X=$E($G(^PRC(442,DA,10,1,0)),1,6)
Q
;
POADJ(PO,PODA,TRNODE,AMT) ;set adjustments in 442
N DIE,DR,DA,X,X1
S X1=AMT
S:AMT<0 AMT=-AMT
S DIE="^PRC(442,"
S DA=PODA
S DR="92///^S X=$S($P(PO(0),U,16)]"""":$P(PO(0),U,16),1:$P(PO(0),U,15))+X1;91///^S X=$P(PO(0),U,15)+X1;7.2///^S X=AMT;3.4///^S X=$P(PO(0),U,7)+$P(TRNODE(3),U,7);94///^S X=$P(PO(8),U,1)+X1"
S:$P(PO(0),U,9) DR=DR_";4.4///^S X=$P(PO(0),U,9)+$P(TRNODE(3),U,9)"
D ^DIE
S PO(0)=^PRC(442,PODA,0)
S X=100
S DA=PODA
D ENF^PRCHSTAT
S:X1'=AMT AMT=X1
Q
;
OBLK(PODA,PRCA) ;look up obligation number
N DIC,Y
S DIC="^PRC(442,"
S DIC(0)="AEMNQZ"
S DIC("A")="Select OBLIGATION NUMBER: "
S DIC("S")="I $P(^(0),U,2)=21"
S:$G(PRCA) DIC("S")=DIC("S")_","_"+$P(^(0),U,3)=PRCA"
D ^DIC
I +Y<0 S PODA=0 Q
S PODA=+Y
S PODA(0)=Y(0)
S PODA(1)=$P(Y,U,2)
S PODA(2)=$P(Y(0),U,3)
Q
;
BAL(PODA,AMT) ;set the 8th node equal to obligation amount
S ^PRC(442,PODA,8)=AMT_"^0^0"
Q
;
KILL(PO) ;if 1358 obligation not completed, set dollar amounts on PAT to 0
;delete 'PRIMARY 2237' field, set status to 'CANCELLED ORDER'
;and delete references to pat number on original request.
N ZZX,XXZ,DIE,DR,X,Y,TRDA,DA
D WAIT^PRCFYN
S ZZX=^PRC(442,PO,0)
S $P(ZZX,U,15,16)="0^0"
F XXZ=7,9 S $P(ZZX,U,XXZ)=0 S $P(ZZX,U,12)=""
S ^PRC(442,PO,0)=ZZX
K XXZ,^(9)
S DA=+$P(ZZX,U,12)
I $D(^PRCS(410,DA,0)) S DIE="^PRCS(410,",DR="52///@;24///@" D ^DIE K DIE,DA,DR,ZZX
S (X,Y)=45,DA=PO
D UPD^PRCHSTAT
K DIE,DA,DR,X,Y
S X="PAT Number "_PATNUM_" has been cancelled."
D MSG^PRCFQ W !
S X="Status on 1358 remains 'Pending Fiscal Action'.*"
D MSG^PRCFQ
S TRDA=+$P(ZZX,U,12)
I $D(^PRCS(410,TRDA,0)) D KILL^PRCS58OB(TRDA)
Q
;
BAL1(PODA,AMT) ;Set liquidation balance
S:$G(^PRC(442,+PODA,8)) $P(^(8),"^",2)=AMT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH58OB 3712 printed Dec 13, 2024@02:05:19 Page 2
PRCH58OB ;WISC/CLH-OBLIGATE,ADJUST 1358 ;11/28/94 15:06
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
COB(DA,TRNODE,PO,OB,X) ;
+1 ;enter transaction information onto PO
+2 ;kills TMP("NEWDATE"),TMP("NEWACC")
+3 NEW DATE,FLAG,I,J,PRCBBFY,SUBSTA,X
+4 SET $PIECE(PO(0),"^",3,9)=$PIECE(TRNODE(3),"^",1,3)_"^"_$PIECE(TRNODE(3),"^",6,9)
+5 SET X=$PIECE(PO(0),"^",7)+$PIECE(PO(0),"^",9)
+6 SET $PIECE(PO(0),"^",11,12)=X_"^"_OB
+7 SET $PIECE(PO(0),"^",15)=$PIECE(TRNODE(4),"^")
+8 FOR I=6,8
SET $PIECE(PO(0),"^",I)=+$PIECE(PO(0),"^",I)
+9 SET PO(1)=$PIECE(TRNODE(3),"^",4,5)
+10 ;
+11 LOCK +^PRC(442,DA)
+12 SET ^PRC(442,DA,0)=PO(0)
+13 SET $PIECE(^PRC(442,DA,1),"^",1,2)=$PIECE(PO(1),"^",1,2)
+14 if $PIECE(PO(0),"^",3)]""
SET ^PRC(442,"E",$PIECE($PIECE(PO(0),"^",3)," "),DA)=""
+15 if $PIECE(PO(1),"^")]""
SET ^PRC(442,"D",$PIECE(PO(1),"^"),DA)=""
+16 IF $DATA(PRCFA("RETRAN"))
IF 'PRCFA("RETRAN")
DO NODE22^PRCFFU5
+17 SET PRCBBFY=$PIECE(TRNODE(3),U,11)
+18 SET SUBSTA=$PIECE(TRNODE(0),"^",10)
+19 if '$DATA(TMP("NEWDATE"))
SET TMP("NEWDATE")=""
+20 if '$DATA(TMP("NEWACC"))
SET TMP("NEWACC")="0^NO"
+21 SET DATE=$PIECE(TMP("NEWDATE"),U)
+22 SET FLAG=$PIECE(TMP("NEWACC"),U)
+23 SET DIE=442
+24 SET DR="26///^S X=PRCBBFY;29///^S X=DATE;30///^S X=FLAG;31///^S X=SUBSTA"
+25 DO ^DIE
+26 KILL DIE,DR
+27 KILL TMP("NEWDATE")
+28 KILL TMP("NEWACC")
+29 IF $PIECE($GET(^PRC(442,DA,12)),"^",2)]""
Begin DoDot:1
+30 DO REMOVE^PRCHES5(DA)
DO ENCODE^PRCHES5(DA,$PIECE(^PRC(442,DA,1),"^",10))
+31 QUIT
End DoDot:1
+32 LOCK -^PRC(442,DA)
+33 QUIT
+34 ;
PAT(DA,PODA,PO,PATNUM) ;get pat info, kill PRCHPO
+1 SET (PO,PODA)=DA
+2 SET PO(0)=$GET(^PRC(442,PODA,0))
+3 SET PATNUM=$PIECE(PO(0),U)
+4 KILL PRCHPO
+5 QUIT
+6 ;
ADJ(DIC,PRC,DA) ;
+1 SET DIC("A")="Select OBLIGATION NUMBER: "
+2 SET DIC(0)="AEQZ"
+3 SET D="D"
+4 SET DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,4)=1,PRC(""SITE"")=+^(0),+PRC(""CP"")=+$P($P(^(0),U),""-"",4)"
+5 DO IX^DIC
+6 QUIT
+7 ;
VER(PRC,X) ;verify entry
+1 SET X=$ORDER(^PRC(442,"B",PRC("SITE")_"-"_X,0))
+2 QUIT
+3 ;
PO(DA,PO) ;PO data for adjustments
+1 NEW I
+2 FOR I=0,1,7,8
SET PO(I)=$GET(^PRC(442,DA,I))
+3 QUIT
+4 ;
OLDTT(DA,X) ;old code sheet info
+1 SET X=$EXTRACT($GET(^PRC(442,DA,10,1,0)),1,6)
+2 QUIT
+3 ;
POADJ(PO,PODA,TRNODE,AMT) ;set adjustments in 442
+1 NEW DIE,DR,DA,X,X1
+2 SET X1=AMT
+3 if AMT<0
SET AMT=-AMT
+4 SET DIE="^PRC(442,"
+5 SET DA=PODA
+6 SET DR="92///^S X=$S($P(PO(0),U,16)]"""":$P(PO(0),U,16),1:$P(PO(0),U,15))+X1;91///^S X=$P(PO(0),U,15)+X1;7.2///^S X=AMT;3.4///^S X=$P(PO(0),U,7)+$P(TRNODE(3),U,7);94///^S X=$P(PO(8),U,1)+X1"
+7 if $PIECE(PO(0),U,9)
SET DR=DR_";4.4///^S X=$P(PO(0),U,9)+$P(TRNODE(3),U,9)"
+8 DO ^DIE
+9 SET PO(0)=^PRC(442,PODA,0)
+10 SET X=100
+11 SET DA=PODA
+12 DO ENF^PRCHSTAT
+13 if X1'=AMT
SET AMT=X1
+14 QUIT
+15 ;
OBLK(PODA,PRCA) ;look up obligation number
+1 NEW DIC,Y
+2 SET DIC="^PRC(442,"
+3 SET DIC(0)="AEMNQZ"
+4 SET DIC("A")="Select OBLIGATION NUMBER: "
+5 SET DIC("S")="I $P(^(0),U,2)=21"
+6 if $GET(PRCA)
SET DIC("S")=DIC("S")_","_"+$P(^(0),U,3)=PRCA"
+7 DO ^DIC
+8 IF +Y<0
SET PODA=0
QUIT
+9 SET PODA=+Y
+10 SET PODA(0)=Y(0)
+11 SET PODA(1)=$PIECE(Y,U,2)
+12 SET PODA(2)=$PIECE(Y(0),U,3)
+13 QUIT
+14 ;
BAL(PODA,AMT) ;set the 8th node equal to obligation amount
+1 SET ^PRC(442,PODA,8)=AMT_"^0^0"
+2 QUIT
+3 ;
KILL(PO) ;if 1358 obligation not completed, set dollar amounts on PAT to 0
+1 ;delete 'PRIMARY 2237' field, set status to 'CANCELLED ORDER'
+2 ;and delete references to pat number on original request.
+3 NEW ZZX,XXZ,DIE,DR,X,Y,TRDA,DA
+4 DO WAIT^PRCFYN
+5 SET ZZX=^PRC(442,PO,0)
+6 SET $PIECE(ZZX,U,15,16)="0^0"
+7 FOR XXZ=7,9
SET $PIECE(ZZX,U,XXZ)=0
SET $PIECE(ZZX,U,12)=""
+8 SET ^PRC(442,PO,0)=ZZX
+9 KILL XXZ,^(9)
+10 SET DA=+$PIECE(ZZX,U,12)
+11 IF $DATA(^PRCS(410,DA,0))
SET DIE="^PRCS(410,"
SET DR="52///@;24///@"
DO ^DIE
KILL DIE,DA,DR,ZZX
+12 SET (X,Y)=45
SET DA=PO
+13 DO UPD^PRCHSTAT
+14 KILL DIE,DA,DR,X,Y
+15 SET X="PAT Number "_PATNUM_" has been cancelled."
+16 DO MSG^PRCFQ
WRITE !
+17 SET X="Status on 1358 remains 'Pending Fiscal Action'.*"
+18 DO MSG^PRCFQ
+19 SET TRDA=+$PIECE(ZZX,U,12)
+20 IF $DATA(^PRCS(410,TRDA,0))
DO KILL^PRCS58OB(TRDA)
+21 QUIT
+22 ;
BAL1(PODA,AMT) ;Set liquidation balance
+1 if $GET(^PRC(442,+PODA,8))
SET $PIECE(^(8),"^",2)=AMT
+2 QUIT
