- PRCHPAM5 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #4 ;11/14/94 3:52 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- E24 ;SOURCE CODE Edit PRINT
- N CHANGE,OLD,NEW,LCNT,DATA
- D LCNT^PRCHPAM5(.LCNT)
- S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",24,8,0)) Q:CHANGE'>0
- S OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P(^PRCD(420.8,OLD,0),U)
- S NEW=$P(^PRC(443.6,PRCHPO,1),U,7),NEW=$P(^PRCD(420.8,NEW,0),U)
- D LINE^PRCHPAM5(.LCNT,2) S DATA="Source Code was changed from "_OLD_" to "_NEW D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- E30 ;F.C.P. Edit PRINT
- N CHANGE,OLD,FCP,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,1,CHANGE)) Q:CHANGE'>0 D
- .S OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- .S FCP=$P(^PRC(443.6,PRCHPO,0),U,3)
- .D LINE^PRCHPAM5(.LCNT,2) S DATA="The FUND CONTROL POINT of "_OLD D DATA^PRCHPAM5(.LCNT,DATA)
- .S DATA="has been changed to "_FCP
- .D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- E31 ;Change VENDOR PRINT
- N CHANGE,OLD,VEN,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,5,CHANGE)) Q:CHANGE'>0 D
- .S OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P(^PRC(440,OLD,0),U)
- .S VEN=$P(^PRC(443.6,PRCHPO,1),U),VEN=$P(^PRC(440,VEN,0),U)
- .D LINE^PRCHPAM5(.LCNT,2) S DATA="Vendor "_OLD_" has been changed to "_VEN
- .D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- E32 ;REPLACE P.O. NUMBER PRINT
- N CHANGE,NPO,OPO,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,28,CHANGE)) Q:CHANGE'>0 D
- .S NPO=$P(^PRC(443.6,PRCHPO,23),U,4) Q:NPO'>0 S NPO=$P(^PRC(443.6,NPO,0),U)
- .S OPO=$P(^PRC(443.6,PRCHPO,0),U)
- .D LINE^PRCHPAM5(.LCNT,2) S DATA="Purchase Order number "_OPO_" has been changed to "_NPO
- .D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- LCNT(LCNT) ;FETCH THE CURRENT LINE COUNT FROM "AMD" ARRAY
- S LCNT=+$G(^TMP($J,"AMD",1))
- Q
- ;
- LINE(LCNT,LINES) ;ADDS A NUMBER OF BLANK "LINES" INTO "AMD" ARRAY
- N I
- F I=1:1:LINES S LCNT=LCNT+1,^TMP($J,"AMD",1,LCNT,0)=" "
- Q
- ;
- DATA(LCNT,DATA) ;PLACES THE AMENDMENT LINE OF TEXT INTO THE "AMD" ARRAY
- S LCNT=LCNT+1,^TMP($J,"AMD",1,LCNT,0)=DATA
- Q
- ;
- LCNT1(LCNT) ;PUT BACK LCNT INTO "AMD" ARRAY
- S ^TMP($J,"AMD",1)=LCNT
- Q
- OLD ;GET ALL THE OLD DESCRIPTION FROM 'CHANGES' MULTIPLE AND SET INTO
- ;THE DESPLAY '^TMP($J,"AMD"' ARRAY.
- N LINE,DATA
- S LINE=1
- F D:DES]"" Q:DES=""
- .S DATA=$E(DES,1,75) D DATA(.LCNT,DATA)
- .S DES=$E(DES,76,255) Q:$L(DES)'<75 Q:LINE'>0
- .S LINE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE)) Q:LINE'>0
- .S DES=DES_$G(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE,0))
- .Q
- Q
- ;
- NEW ;GET ALL THE NEW DESCRIPTION FROM THE LINE ITEM MULTIPLE AND SET
- ;INTO THE DISPLAY '^TMP($J,"AMD"' ARRAY.
- N LINE,DATA
- S LINE=1
- F D:ITEM1]"" Q:ITEM1=""
- .S DATA=$E(ITEM1,1,75) D DATA(.LCNT,DATA)
- .S ITEM1=$E(ITEM1,76,255) Q:$L(ITEM1)'<75 Q:LINE'>0
- .S LINE=$O(^PRC(443.6,PRCHPO,2,ITEM,1,LINE)) Q:LINE'>0
- .S ITEM1=ITEM1_$G(^PRC(443.6,PRCHPO,2,ITEM,1,LINE,0))
- .Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHPAM5 3180 printed Jan 18, 2025@03:10:29 Page 2
- PRCHPAM5 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #4 ;11/14/94 3:52 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- E24 ;SOURCE CODE Edit PRINT
- +1 NEW CHANGE,OLD,NEW,LCNT,DATA
- +2 DO LCNT^PRCHPAM5(.LCNT)
- +3 SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",24,8,0))
- if CHANGE'>0
- QUIT
- +4 SET OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- SET OLD=$PIECE(^PRCD(420.8,OLD,0),U)
- +5 SET NEW=$PIECE(^PRC(443.6,PRCHPO,1),U,7)
- SET NEW=$PIECE(^PRCD(420.8,NEW,0),U)
- +6 DO LINE^PRCHPAM5(.LCNT,2)
- SET DATA="Source Code was changed from "_OLD_" to "_NEW
- DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- +7 QUIT
- +8 ;
- E30 ;F.C.P. Edit PRINT
- +1 NEW CHANGE,OLD,FCP,LCNT,DATA
- +2 SET CHANGE=0
- DO LCNT^PRCHPAM5(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,1,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- +5 SET FCP=$PIECE(^PRC(443.6,PRCHPO,0),U,3)
- +6 DO LINE^PRCHPAM5(.LCNT,2)
- SET DATA="The FUND CONTROL POINT of "_OLD
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +7 SET DATA="has been changed to "_FCP
- +8 DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- End DoDot:1
- +9 QUIT
- +10 ;
- E31 ;Change VENDOR PRINT
- +1 NEW CHANGE,OLD,VEN,LCNT,DATA
- +2 SET CHANGE=0
- DO LCNT^PRCHPAM5(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,5,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- SET OLD=$PIECE(^PRC(440,OLD,0),U)
- +5 SET VEN=$PIECE(^PRC(443.6,PRCHPO,1),U)
- SET VEN=$PIECE(^PRC(440,VEN,0),U)
- +6 DO LINE^PRCHPAM5(.LCNT,2)
- SET DATA="Vendor "_OLD_" has been changed to "_VEN
- +7 DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- End DoDot:1
- +8 QUIT
- +9 ;
- E32 ;REPLACE P.O. NUMBER PRINT
- +1 NEW CHANGE,NPO,OPO,LCNT,DATA
- +2 SET CHANGE=0
- DO LCNT^PRCHPAM5(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,28,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET NPO=$PIECE(^PRC(443.6,PRCHPO,23),U,4)
- if NPO'>0
- QUIT
- SET NPO=$PIECE(^PRC(443.6,NPO,0),U)
- +5 SET OPO=$PIECE(^PRC(443.6,PRCHPO,0),U)
- +6 DO LINE^PRCHPAM5(.LCNT,2)
- SET DATA="Purchase Order number "_OPO_" has been changed to "_NPO
- +7 DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- End DoDot:1
- +8 QUIT
- +9 ;
- LCNT(LCNT) ;FETCH THE CURRENT LINE COUNT FROM "AMD" ARRAY
- +1 SET LCNT=+$GET(^TMP($JOB,"AMD",1))
- +2 QUIT
- +3 ;
- LINE(LCNT,LINES) ;ADDS A NUMBER OF BLANK "LINES" INTO "AMD" ARRAY
- +1 NEW I
- +2 FOR I=1:1:LINES
- SET LCNT=LCNT+1
- SET ^TMP($JOB,"AMD",1,LCNT,0)=" "
- +3 QUIT
- +4 ;
- DATA(LCNT,DATA) ;PLACES THE AMENDMENT LINE OF TEXT INTO THE "AMD" ARRAY
- +1 SET LCNT=LCNT+1
- SET ^TMP($JOB,"AMD",1,LCNT,0)=DATA
- +2 QUIT
- +3 ;
- LCNT1(LCNT) ;PUT BACK LCNT INTO "AMD" ARRAY
- +1 SET ^TMP($JOB,"AMD",1)=LCNT
- +2 QUIT
- OLD ;GET ALL THE OLD DESCRIPTION FROM 'CHANGES' MULTIPLE AND SET INTO
- +1 ;THE DESPLAY '^TMP($J,"AMD"' ARRAY.
- +2 NEW LINE,DATA
- +3 SET LINE=1
- +4 FOR
- if DES]""
- Begin DoDot:1
- +5 SET DATA=$EXTRACT(DES,1,75)
- DO DATA(.LCNT,DATA)
- +6 SET DES=$EXTRACT(DES,76,255)
- if $LENGTH(DES)'<75
- QUIT
- if LINE'>0
- QUIT
- +7 SET LINE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE))
- if LINE'>0
- QUIT
- +8 SET DES=DES_$GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE,0))
- +9 QUIT
- End DoDot:1
- if DES=""
- QUIT
- +10 QUIT
- +11 ;
- NEW ;GET ALL THE NEW DESCRIPTION FROM THE LINE ITEM MULTIPLE AND SET
- +1 ;INTO THE DISPLAY '^TMP($J,"AMD"' ARRAY.
- +2 NEW LINE,DATA
- +3 SET LINE=1
- +4 FOR
- if ITEM1]""
- Begin DoDot:1
- +5 SET DATA=$EXTRACT(ITEM1,1,75)
- DO DATA(.LCNT,DATA)
- +6 SET ITEM1=$EXTRACT(ITEM1,76,255)
- if $LENGTH(ITEM1)'<75
- QUIT
- if LINE'>0
- QUIT
- +7 SET LINE=$ORDER(^PRC(443.6,PRCHPO,2,ITEM,1,LINE))
- if LINE'>0
- QUIT
- +8 SET ITEM1=ITEM1_$GET(^PRC(443.6,PRCHPO,2,ITEM,1,LINE,0))
- +9 QUIT
- End DoDot:1
- if ITEM1=""
- QUIT
- +10 QUIT