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 Dec 13, 2024@02:09:17 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
