117 lines
5.3 KiB
Mathematica
117 lines
5.3 KiB
Mathematica
PRCHAMYB ;WISC/DJM-MOVING AMENDMENT INFO FROM 443.6 TO 442 ;4/4/95 10:57 AM
|
|
V ;;5.1;IFCAP;**79,100**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
N PRCIEN,PRCIEN1,PRCDSL,PAT,PRCDS,PRCDATA,PRCAS,FLAG,DIC,X,DIK,PRCHIEN,LAST,%X,%Y,LOOP,LOOPVAL,DA,MESSG1,CHECKSUM,PRCHPO1,PRCHPOX,PRCHPO2,STATUS,FCP,IMF,O0,O1,PODATE,Y,PRCOPODA
|
|
S PRCIEN=0 F S PRCIEN=$O(^PRC(442,PRCHPO,6,PRCHAM,3,PRCIEN)) Q:PRCIEN'>0 D
|
|
.S PRCIEN1=$G(^PRC(442,PRCHPO,6,PRCHAM,3,PRCIEN,0)) Q:PRCIEN1=""
|
|
.S PRCDSL=$P(PRCIEN1,U,7) Q:PRCDSL'>0
|
|
.S ^PRC(442,PRCHPO,6,PRCHAM,3,"AD",PRCDSL,PRCIEN)=""
|
|
.Q
|
|
;
|
|
COPY2 ;NOW TO COPY ANY DELIVERY SCHEDULES FROM 441.7 TO 442.8.
|
|
S FLAG=0,PAT=$P(^PRC(443.6,PRCHPO,0),U,1),PRCDS=""
|
|
F S PRCDS=$O(^PRC(441.7,"AG",PAT,PRCDS)) Q:PRCDS'>0 D Q:FLAG>0
|
|
.S PRCDSL="" F S PRCDSL=$O(^PRC(441.7,"AG",PAT,PRCDS,PRCDSL)) Q:PRCDSL'>0 D Q:FLAG>0
|
|
..S PRCDATA=$G(^PRC(441.7,PRCDSL,0))
|
|
..S PRCAS=$P(PRCDATA,U,7)
|
|
..S PRCDATA=$P(PRCDATA,U,1,6)
|
|
..S PRCDELF=$P(PRCDATA,U,6)
|
|
..S:PRCAS>0&(PRCDELF="") ^PRC(442.8,PRCAS,0)=PRCDATA
|
|
..I PRCAS>0&(PRCDELF="D") D
|
|
...S DIK="^PRC(442.8,"
|
|
...S DA=PRCAS
|
|
...D ^DIK
|
|
...Q
|
|
..I PRCAS'>0 D Q:FLAG>0
|
|
...S DIC="^PRC(442.8,",DIC(0)="L",X=PAT K DD,DO D FILE^DICN I Y'>0 W !,"An error has occurred while restoring file 442.8 for "_PAT,!,",item "_PRCDS_"." S FLAG=1 Q
|
|
...S PRCAS=$S(PRCAS>0:PRCAS,1:+Y),^PRC(442.8,PRCAS,0)=PRCDATA
|
|
..Q:FLAG>0
|
|
..S DIK="^PRC(442.8,",DA=$S(PRCAS>0:PRCAS,1:+Y) D IX^DIK
|
|
..S PRCHIEN=0 F S PRCHIEN=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AD",PRCDSL,PRCHIEN)) Q:PRCHIEN="" S $P(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHIEN,0),U,7)=PRCAS
|
|
..Q
|
|
.Q
|
|
Q:FLAG>0
|
|
ROLL ;THIS WILL DO THE LINE ITEM ROLL-UP INTO ALL THE 'BOC's.
|
|
S LAST=0,%X="^PRC(442,PRCHPO,22,",%Y="^PRC(443.6,PRCHPO,22," D %XY^%RCR
|
|
S LOOP=0 F S LOOP=$O(^PRC(442,PRCHPO,22,LOOP)) Q:LOOP'>0 D
|
|
.S LOOPVAL=$G(^PRC(442,PRCHPO,22,LOOP,0)),$P(LOOPVAL,U,2)=0
|
|
.S ^PRC(442,PRCHPO,22,LOOP,0)=LOOPVAL I $P(LOOPVAL,U,3)'=991,$P(LOOPVAL,U,3)>LAST S LAST=$P(LOOPVAL,U,3)
|
|
.Q
|
|
S DA=PRCHPO D ^PRCHAMYC,^PRCHSF1
|
|
S (MESSG1,CHECKSUM)="" D RECODE^PRCHES5(PRCHPO,CHECKSUM,.MESSG1)
|
|
;
|
|
CLEANUP ;THE CODE FOLLOWING THIS COMMENT WILL DELETE THE TEMPORARY FILE
|
|
;ENTRIES IN FILE 443.6 AND 441.7 FOR PRCHPO ENTRY FROM 442 AND 442.8
|
|
;FILES.
|
|
S PRCHPO1=$P($G(^PRC(443.6,PRCHPO,0)),U),PRCHPOX=$P($G(^PRC(443.6,PRCHPO,23)),U,4)
|
|
I PRCHPOX]"" S PRCHPO2=$P($G(^PRC(443.6,PRCHPOX,0)),U)
|
|
K ^PRC(443.6,PRCHPO) I PRCHPOX>0 K ^PRC(443.6,PRCHPOX)
|
|
K ^PRC(443.6,"E",$P(PRCHPO1,"-",2),PRCHPO),^PRC(443.6,"B",PRCHPO1,PRCHPO),^PRC(443.6,"D",PRCHPO),^PRC(443.6,"C",PRCHPO,PRCHAM)
|
|
I PRCHPOX>0 K ^PRC(443.6,"E",$P(PRCHPO2,"-",2),PRCHPOX),^PRC(443.6,"B",PRCHPO2,PRCHPOX),^PRC(443.6,"D",PRCHPOX),^PRC(443.6,"C",PRCHPOX,PRCHAM)
|
|
S PRCDS="" F S PRCDS=$O(^PRC(441.7,"B",PRCHPO1,PRCDS)) Q:PRCDS'>0 D
|
|
.S DIK="^PRC(441.7,",DA=PRCDS D ^DIK
|
|
.Q
|
|
;
|
|
STATUS ;NOW TO UPDATE THE 'SUPPLY STATUS', FIELD .5. THIS WILL UPDATE
|
|
;THE P.O. STATUS TO EQUAL THE LATEST AMENDMENT STATUS.
|
|
S STATUS=$P($G(^PRC(442,PRCHPO,6,PRCHAM,1)),U,4),DR=".5////^S X=STATUS",DIE="^PRC(442,",DA=PRCHPO D ^DIE
|
|
S PRCOPODA=PRCHPO_"^"_1_"^"_PRCHAM
|
|
; ...now generating the PHM transaction...
|
|
D NEW^PRCOEDI ; set up & send PHM
|
|
; Create FPDS message for the AAC, PRC*5.1*79. Check if the order was
|
|
; amended but the total dollar amount did not. If there is a cancellation, then send the HL7 message.
|
|
;PRC*5.1*100: check node 9 and the source code before sending PO to FPDS. Source codes 0,1,3, and 9 not required by FPDS - IEN stored in global.
|
|
I "1378"[$P(^PRC(442,PRCHPO,1),U,7) G OUT1
|
|
I $P(^PRC(442,PRCHPO,0),U,15)>0,$D(^PRC(442,PRCHPO,25)),$D(^PRC(442,PRCHPO,9,1,0)) D
|
|
. I $D(^PRC(442,PRCHPO,6,0)) D
|
|
.. S PRCMN=$P(^PRC(442,PRCHPO,6,0),U,3)
|
|
.. I $P(^PRC(442,PRCHPO,6,PRCMN,0),U,3)=0,$P(^PRC(442,PRCHPO,7),U,2)'=45 S PRCQ=1
|
|
. D:$G(PRCQ)'=1 EN^DDIOL("...now generating the FPDS message for the AAC...","","!!"),EN^DDIOL(" ")
|
|
. D:$G(PRCQ)'=1 AAC^PRCHAAC
|
|
; End of changes for PRC*5.1*79
|
|
OUT1 K PRCOPODA,PRCQ,PRCMN
|
|
I STATUS'=45 G EXIT
|
|
S AUTH=$P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),U,4)
|
|
G:AUTH="" EXIT
|
|
G:'((AUTH=5)!(AUTH=15)) UPDATE
|
|
K AUTH,REF,REF1 G EXIT
|
|
;
|
|
UPDATE ;UPDATE FILE 410 TO POINT TO THE CORRECT P.O.
|
|
S O0=$G(^PRC(442,PRCHPO,0))
|
|
S O1=$G(^PRC(442,PRCHPO,1))
|
|
S FCP=+$P(O0,U)_+$P(O0,U,3)
|
|
S PODATE=+$P(O1,U,15)
|
|
S NEWPO=$P($G(^PRC(442,PRCHPO,23)),U,4)
|
|
G:NEWPO="" FINI
|
|
S PRCOPODA=NEWPO_"^"_2_"^"_PRCHAM_"^"_PRCHPO
|
|
;...now generating PHA transaction...
|
|
D NEW^PRCOEDI
|
|
K PRCOPODA
|
|
S LOOP=0 F S LOOP=$O(^PRC(442,NEWPO,2,LOOP)) Q:LOOP'>0 D
|
|
.S L0=$G(^PRC(442,NEWPO,2,LOOP,0))
|
|
.S L2=$G(^PRC(442,NEWPO,2,LOOP,2))
|
|
.S L0=$P(L0,U,10),L2=$P(L2,U,13)
|
|
.Q:L0=""!(L2="")
|
|
.I $P(L0,U,5)>0 D
|
|
..S IMF=$P(L0,U,5)
|
|
..K ^PRC(441,IMF,4,FCP,1,PRCHPO,0)
|
|
..S ^PRC(441,IMF,4,FCP,1,NEWPO,0)=NEWPO
|
|
..K ^PRC(441,IMF,4,FCP,1,"AC",9999999-PODATE,PRCHPO)
|
|
..S ^PRC(441,IMF,4,FCP,1,"AC",9999999-PODATE,NEWPO)=""
|
|
..Q
|
|
.S DA(1)=L0,DA=L2,DIE="^PRCS(410,"_DA(1)_",""IT"",",DR="9///^S X=NEWPO"
|
|
.D ^DIE
|
|
.Q
|
|
S PRC2237=$P($G(^PRC(442,PRCHPO,0)),U,12) G:PRC2237'>0 FINI
|
|
S PRCCNS=$P($P($G(^PRC(442,NEWPO,0)),U),"-",2)
|
|
S OLDCNS=$P(^PRCS(410,PRC2237,4),U,5)
|
|
K ^PRCS(410,"D",OLDCNS,PRC2237)
|
|
S $P(^PRCS(410,PRC2237,4),U,5)=PRCCNS
|
|
S ^PRCS(410,"D",PRCCNS,PRC2237)=""
|
|
S $P(^PRCS(410,PRC2237,10),U,3)=NEWPO
|
|
S MESSAGE="" D RECODE^PRCSC2(PRC2237,.MESSAGE)
|
|
I MESSAGE'=1 W !,"An error has occurred while recoding an ESIG.",!
|
|
FINI K NEWPO,LOOP,L0,L2,DIE,DR,PRC2237,OLDCNS,PRCCNS,MESSAGE
|
|
EXIT G OTHER^PRCHAMYD
|