PRCSES2 ;SF-ISC/KSS/LJP-X-REF SET STATEMENT FOR ITEM QTY ;9/17/92 3:40 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q:'$D(^PRCS(410,DA(1),"IT",DA,0)) Q:'$P(^(0),U,2)
S E=0,E(1)="" S:'$D(^PRCS(410,DA(1),4)) ^(4)=""
F E(0)=1:1 S E=$O(^PRCS(410,DA(1),"IT",E)) S:E?1N.N E(1)=E(1)+($P(^(E,0),U,2)*$P(^(0),U,7)) I E'?1N.N D PR1 K E Q
K E Q
PR1 S ^PRCS(410,DA(1),4)=E(1)_U_$P(^PRCS(410,DA(1),4),U,2,99),E=DA,E(2)=DA(1),X=E(1),DA=DA(1) D PR2 S DA=E,DA(1)=E(2) Q
PR2 Q:$P(^PRCS(410,DA,4),U,3)'="" S $P(^(4),U,8)=X D TRANS^PRCSES Q
OBL ;copy or null fields for 1358 adj in file 410
N A,GOFLAG
S A=+$G(^PRCS(410,DA,0))
K PRCS(2) S (PRCS(1),PRCSI,GOFLAG)=0
F PRCSI=0:0 S PRCS(1)=$O(^PRCS(410,"D",PRCX442,PRCS(1))) Q:PRCS(1)'>0 D I GOFLAG S PRCS(2)="" Q
.; additional checks added for checking FORM TYPE and FY
.; X1 = FY from newly created adjustment
.; x2 = FY from record being checked
.S X2=$P($P(^PRCS(410,PRCS(1),0),U),"-",2)
.S X2=$$YEAR^PRC0C(X2),X2=$P(X2,U)
.S X2=$$DATE^PRC0C(X2,"E"),X2=$P(X2,U,7)
.S X1=$P($P(^PRCS(410,DA,0),U),"-",2)
.S X1=$$YEAR^PRC0C(X1),X1=$P(X1,U)
.S X1=$$DATE^PRC0C(X1,"E"),X1=$P(X1,U,7)
.D ^%DTC
.I $D(^PRCS(410,PRCS(1),0)),$P(^(0),U,2)="O",+^(0)=A,$P(^(0),U,4)=1,X<1865 S GOFLAG=1
.Q
I '$D(PRCS(2)) K PRCS(1),PRCSI Q
I $D(^PRCS(410,PRCS(1),11)),$P(^(11),U)]"" S ^PRCS(410,DA,11)=$P(^PRCS(410,PRCS(1),11),U),^PRCS(410,"J",$P(^(11),U),DA)=""
I $D(^PRCS(410,PRCS(1),2)) S $P(^PRCS(410,DA,2),U)=$P(^PRCS(410,PRCS(1),2),U),^PRCS(410,"E",$E($P(^(2),U),1,30),DA)="" S:$D(^PRCS(410,PRCS(1),3)) $P(^PRCS(410,DA,3),U,4)=$P(^PRCS(410,PRCS(1),3),U,4)
S:$P(^PRCS(410,PRCS(1),0),U,4)=1 PRCS58=1
I $D(^PRCS(410,PRCS(1),3)) S $P(^PRCS(410,DA,3),U,2,3)=$P(^(3),U,2,3),^PRCS(410,"AC",$P(^(3),U,3),DA)=""
I $D(^PRCS(410,PRCS(1),3)),$P(^(3),U,6)]"" S $P(^PRCS(410,DA,3),U,6)=$P(^(3),U,6),^PRCS(410,"AD",$P(^(3),U,6),DA)=""
I $D(^PRCS(410,PRCS(1),3)),$P(^(3),U,8)]"" S $P(^PRCS(410,DA,3),U,8)=$P(^(3),U,8),^PRCS(410,"AP",$P(^(3),U,8),DA)=""
K PRCS(1),PRCS(2),PRCSI Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSES2 2090 printed Dec 13, 2024@02:17:43 Page 2
PRCSES2 ;SF-ISC/KSS/LJP-X-REF SET STATEMENT FOR ITEM QTY ;9/17/92 3:40 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 if '$DATA(^PRCS(410,DA(1),"IT",DA,0))
QUIT
if '$PIECE(^(0),U,2)
QUIT
+3 SET E=0
SET E(1)=""
if '$DATA(^PRCS(410,DA(1),4))
SET ^(4)=""
+4 FOR E(0)=1:1
SET E=$ORDER(^PRCS(410,DA(1),"IT",E))
if E?1N.N
SET E(1)=E(1)+($PIECE(^(E,0),U,2)*$PIECE(^(0),U,7))
IF E'?1N.N
DO PR1
KILL E
QUIT
+5 KILL E
QUIT
PR1 SET ^PRCS(410,DA(1),4)=E(1)_U_$PIECE(^PRCS(410,DA(1),4),U,2,99)
SET E=DA
SET E(2)=DA(1)
SET X=E(1)
SET DA=DA(1)
DO PR2
SET DA=E
SET DA(1)=E(2)
QUIT
PR2 if $PIECE(^PRCS(410,DA,4),U,3)'=""
QUIT
SET $PIECE(^(4),U,8)=X
DO TRANS^PRCSES
QUIT
OBL ;copy or null fields for 1358 adj in file 410
+1 NEW A,GOFLAG
+2 SET A=+$GET(^PRCS(410,DA,0))
+3 KILL PRCS(2)
SET (PRCS(1),PRCSI,GOFLAG)=0
+4 FOR PRCSI=0:0
SET PRCS(1)=$ORDER(^PRCS(410,"D",PRCX442,PRCS(1)))
if PRCS(1)'>0
QUIT
Begin DoDot:1
+5 ; additional checks added for checking FORM TYPE and FY
+6 ; X1 = FY from newly created adjustment
+7 ; x2 = FY from record being checked
+8 SET X2=$PIECE($PIECE(^PRCS(410,PRCS(1),0),U),"-",2)
+9 SET X2=$$YEAR^PRC0C(X2)
SET X2=$PIECE(X2,U)
+10 SET X2=$$DATE^PRC0C(X2,"E")
SET X2=$PIECE(X2,U,7)
+11 SET X1=$PIECE($PIECE(^PRCS(410,DA,0),U),"-",2)
+12 SET X1=$$YEAR^PRC0C(X1)
SET X1=$PIECE(X1,U)
+13 SET X1=$$DATE^PRC0C(X1,"E")
SET X1=$PIECE(X1,U,7)
+14 DO ^%DTC
+15 IF $DATA(^PRCS(410,PRCS(1),0))
IF $PIECE(^(0),U,2)="O"
IF +^(0)=A
IF $PIECE(^(0),U,4)=1
IF X<1865
SET GOFLAG=1
+16 QUIT
End DoDot:1
IF GOFLAG
SET PRCS(2)=""
QUIT
+17 IF '$DATA(PRCS(2))
KILL PRCS(1),PRCSI
QUIT
+18 IF $DATA(^PRCS(410,PRCS(1),11))
IF $PIECE(^(11),U)]""
SET ^PRCS(410,DA,11)=$PIECE(^PRCS(410,PRCS(1),11),U)
SET ^PRCS(410,"J",$PIECE(^(11),U),DA)=""
+19 IF $DATA(^PRCS(410,PRCS(1),2))
SET $PIECE(^PRCS(410,DA,2),U)=$PIECE(^PRCS(410,PRCS(1),2),U)
SET ^PRCS(410,"E",$EXTRACT($PIECE(^(2),U),1,30),DA)=""
if $DATA(^PRCS(410,PRCS(1),3))
SET $PIECE(^PRCS(410,DA,3),U,4)=$PIECE(^PRCS(410,PRCS(1),3),U,4)
+20 if $PIECE(^PRCS(410,PRCS(1),0),U,4)=1
SET PRCS58=1
+21 IF $DATA(^PRCS(410,PRCS(1),3))
SET $PIECE(^PRCS(410,DA,3),U,2,3)=$PIECE(^(3),U,2,3)
SET ^PRCS(410,"AC",$PIECE(^(3),U,3),DA)=""
+22 IF $DATA(^PRCS(410,PRCS(1),3))
IF $PIECE(^(3),U,6)]""
SET $PIECE(^PRCS(410,DA,3),U,6)=$PIECE(^(3),U,6)
SET ^PRCS(410,"AD",$PIECE(^(3),U,6),DA)=""
+23 IF $DATA(^PRCS(410,PRCS(1),3))
IF $PIECE(^(3),U,8)]""
SET $PIECE(^PRCS(410,DA,3),U,8)=$PIECE(^(3),U,8)
SET ^PRCS(410,"AP",$PIECE(^(3),U,8),DA)=""
+24 KILL PRCS(1),PRCS(2),PRCSI
QUIT