- 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 Feb 18, 2025@23:44:05 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