- PRC159P1 ;VMP/RB-PURGE ALL DUPLICATE PRC(442,"AB" ORDER DATE REFERENCES
- ;;5.1;IFCAP;**159**;Oct 01, 2009;Build 9
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ; Pre install routine in patch PRC*5.1*159 that will purge duplicate
- ; entries in cross reference ^PRC(442,"AB") that were left
- ; unkilled when the order was edited on a subsequent date.
- ;;
- Q
- START ;Kill off extraneous index xref left behind when using CHANGE EXISTING TRANSACTION NUMBER option
- N RMSTART,IEN442,RMEND,R0,R1,TOT,TOT1,TOT3,TOT4,TOT5,PRCODT,PRCODT0
- I $D(^XTMP("PRC159P1")) Q
- D NOW^%DTC S RMSTART=%
- S ^XTMP("PRC159P1","START COMPILE")=RMSTART
- S ^XTMP("PRC159P1","END COMPILE")="RUNNING"
- S ^XTMP("PRC159P1",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
- S U="^",PRCODT=0,(TOT,TOT1,TOT3,TOT4,TOT5)=0
- 1 S PRCODT=$O(^PRC(442,"AB",PRCODT)),IEN442=0 G 5:PRCODT=""
- 2 S IEN442=$O(^PRC(442,"AB",PRCODT,IEN442)) G 1:IEN442=""
- S TOT=TOT+1
- I '$D(^PRC(442,IEN442,0)) D G 2
- . S TOT4=TOT4+1
- . K ^PRC(442,"AB",PRCODT,IEN442)
- . S ^XTMP("PRC159P1","M0",IEN442,PRCODT)=""
- I '$D(^PRC(442,IEN442,1)) D G 2
- . S TOT5=TOT5+1
- . K ^PRC(442,"AB",PRCODT,IEN442)
- . S ^XTMP("PRC159P1","M1",IEN442,PRCODT)=""
- S R0=$G(^PRC(442,IEN442,0)),R1=$G(^PRC(442,IEN442,1)),PRCODT0=$P(R1,U,15)
- I PRCODT'=PRCODT0 D
- . S TOT1=TOT1+1
- . K ^PRC(442,"AB",PRCODT,IEN442)
- . S ^XTMP("PRC159P1","D",IEN442,PRCODT)=PRCODT0
- G 2
- ;Insures that all file 442 entries have an 'AB' x-ref
- 5 S IEN442=0
- 6 S IEN442=$O(^PRC(442,IEN442)) G EXIT:IEN442=""
- I '$D(^PRC(442,IEN442,1)) G 6
- S R0=$G(^PRC(442,IEN442,0)),R1=$G(^PRC(442,IEN442,1)),PRCODT0=$P(R1,U,15)
- I 'PRCODT0 G 6
- I '$D(^PRC(442,"AB",PRCODT0,IEN442)) D
- . S TOT3=TOT3+1
- . S ^PRC(442,"AB",PRCODT0,IEN442)=""
- . S ^XTMP("PRC159P1","S",IEN442,PRCODT0)=$P(R0,U)
- G 6
- EXIT ;
- D NOW^%DTC S RMEND=%
- S ^XTMP("PRC159P1","TOTALS")=TOT_U_TOT1_U_TOT3_U_TOT4_U_TOT5
- S ^XTMP("PRC159P1","END COMPILE")=RMEND
- W !!,"Number of assigned 'AB' cross references: ",TOT
- W !!,"Number of purged 'AB' x-ref with undefined node 0 in file 442: ",TOT4
- W !!,"Number of purged 'AB' x-ref with undefined node 1 in file 442: ",TOT5
- W !!,"Number of purged 'AB' x-ref with diff node 1 P.O. Date: ",TOT1
- W !!,"Number of created 'AB' x-ref for 442 orders missing P.O. Date x-ref: ",TOT3
- K %
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC159P1 2344 printed Feb 18, 2025@23:25:48 Page 2
- PRC159P1 ;VMP/RB-PURGE ALL DUPLICATE PRC(442,"AB" ORDER DATE REFERENCES
- +1 ;;5.1;IFCAP;**159**;Oct 01, 2009;Build 9
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ; Pre install routine in patch PRC*5.1*159 that will purge duplicate
- +4 ; entries in cross reference ^PRC(442,"AB") that were left
- +5 ; unkilled when the order was edited on a subsequent date.
- +6 ;;
- +7 QUIT
- START ;Kill off extraneous index xref left behind when using CHANGE EXISTING TRANSACTION NUMBER option
- +1 NEW RMSTART,IEN442,RMEND,R0,R1,TOT,TOT1,TOT3,TOT4,TOT5,PRCODT,PRCODT0
- +2 IF $DATA(^XTMP("PRC159P1"))
- QUIT
- +3 DO NOW^%DTC
- SET RMSTART=%
- +4 SET ^XTMP("PRC159P1","START COMPILE")=RMSTART
- +5 SET ^XTMP("PRC159P1","END COMPILE")="RUNNING"
- +6 SET ^XTMP("PRC159P1",0)=$$FMADD^XLFDT(RMSTART,120)_"^"_RMSTART
- +7 SET U="^"
- SET PRCODT=0
- SET (TOT,TOT1,TOT3,TOT4,TOT5)=0
- 1 SET PRCODT=$ORDER(^PRC(442,"AB",PRCODT))
- SET IEN442=0
- if PRCODT=""
- GOTO 5
- 2 SET IEN442=$ORDER(^PRC(442,"AB",PRCODT,IEN442))
- if IEN442=""
- GOTO 1
- +1 SET TOT=TOT+1
- +2 IF '$DATA(^PRC(442,IEN442,0))
- Begin DoDot:1
- +3 SET TOT4=TOT4+1
- +4 KILL ^PRC(442,"AB",PRCODT,IEN442)
- +5 SET ^XTMP("PRC159P1","M0",IEN442,PRCODT)=""
- End DoDot:1
- GOTO 2
- +6 IF '$DATA(^PRC(442,IEN442,1))
- Begin DoDot:1
- +7 SET TOT5=TOT5+1
- +8 KILL ^PRC(442,"AB",PRCODT,IEN442)
- +9 SET ^XTMP("PRC159P1","M1",IEN442,PRCODT)=""
- End DoDot:1
- GOTO 2
- +10 SET R0=$GET(^PRC(442,IEN442,0))
- SET R1=$GET(^PRC(442,IEN442,1))
- SET PRCODT0=$PIECE(R1,U,15)
- +11 IF PRCODT'=PRCODT0
- Begin DoDot:1
- +12 SET TOT1=TOT1+1
- +13 KILL ^PRC(442,"AB",PRCODT,IEN442)
- +14 SET ^XTMP("PRC159P1","D",IEN442,PRCODT)=PRCODT0
- End DoDot:1
- +15 GOTO 2
- +16 ;Insures that all file 442 entries have an 'AB' x-ref
- 5 SET IEN442=0
- 6 SET IEN442=$ORDER(^PRC(442,IEN442))
- if IEN442=""
- GOTO EXIT
- +1 IF '$DATA(^PRC(442,IEN442,1))
- GOTO 6
- +2 SET R0=$GET(^PRC(442,IEN442,0))
- SET R1=$GET(^PRC(442,IEN442,1))
- SET PRCODT0=$PIECE(R1,U,15)
- +3 IF 'PRCODT0
- GOTO 6
- +4 IF '$DATA(^PRC(442,"AB",PRCODT0,IEN442))
- Begin DoDot:1
- +5 SET TOT3=TOT3+1
- +6 SET ^PRC(442,"AB",PRCODT0,IEN442)=""
- +7 SET ^XTMP("PRC159P1","S",IEN442,PRCODT0)=$PIECE(R0,U)
- End DoDot:1
- +8 GOTO 6
- EXIT ;
- +1 DO NOW^%DTC
- SET RMEND=%
- +2 SET ^XTMP("PRC159P1","TOTALS")=TOT_U_TOT1_U_TOT3_U_TOT4_U_TOT5
- +3 SET ^XTMP("PRC159P1","END COMPILE")=RMEND
- +4 WRITE !!,"Number of assigned 'AB' cross references: ",TOT
- +5 WRITE !!,"Number of purged 'AB' x-ref with undefined node 0 in file 442: ",TOT4
- +6 WRITE !!,"Number of purged 'AB' x-ref with undefined node 1 in file 442: ",TOT5
- +7 WRITE !!,"Number of purged 'AB' x-ref with diff node 1 P.O. Date: ",TOT1
- +8 WRITE !!,"Number of created 'AB' x-ref for 442 orders missing P.O. Date x-ref: ",TOT3
- +9 KILL %
- +10 QUIT
