PRCHAMYB ;WISC/DJM-MOVING AMENDMENT INFO FROM 443.6 TO 442 ;4/4/95 10:57 AM
V ;;5.1;IFCAP;**79,100,220**;Oct 20, 2000;Build 23
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*220 Comment out line related to FPDS message generation
;
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(" ") PRC*5.1*220
. 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAMYB 5665 printed Dec 13, 2024@02:06 Page 2
PRCHAMYB ;WISC/DJM-MOVING AMENDMENT INFO FROM 443.6 TO 442 ;4/4/95 10:57 AM
V ;;5.1;IFCAP;**79,100,220**;Oct 20, 2000;Build 23
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*220 Comment out line related to FPDS message generation
+4 ;
+5 NEW 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
+6 SET PRCIEN=0
FOR
SET PRCIEN=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,PRCIEN))
if PRCIEN'>0
QUIT
Begin DoDot:1
+7 SET PRCIEN1=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,PRCIEN,0))
if PRCIEN1=""
QUIT
+8 SET PRCDSL=$PIECE(PRCIEN1,U,7)
if PRCDSL'>0
QUIT
+9 SET ^PRC(442,PRCHPO,6,PRCHAM,3,"AD",PRCDSL,PRCIEN)=""
+10 QUIT
End DoDot:1
+11 ;
COPY2 ;NOW TO COPY ANY DELIVERY SCHEDULES FROM 441.7 TO 442.8.
+1 SET FLAG=0
SET PAT=$PIECE(^PRC(443.6,PRCHPO,0),U,1)
SET PRCDS=""
+2 FOR
SET PRCDS=$ORDER(^PRC(441.7,"AG",PAT,PRCDS))
if PRCDS'>0
QUIT
Begin DoDot:1
+3 SET PRCDSL=""
FOR
SET PRCDSL=$ORDER(^PRC(441.7,"AG",PAT,PRCDS,PRCDSL))
if PRCDSL'>0
QUIT
Begin DoDot:2
+4 SET PRCDATA=$GET(^PRC(441.7,PRCDSL,0))
+5 SET PRCAS=$PIECE(PRCDATA,U,7)
+6 SET PRCDATA=$PIECE(PRCDATA,U,1,6)
+7 SET PRCDELF=$PIECE(PRCDATA,U,6)
+8 if PRCAS>0&(PRCDELF="")
SET ^PRC(442.8,PRCAS,0)=PRCDATA
+9 IF PRCAS>0&(PRCDELF="D")
Begin DoDot:3
+10 SET DIK="^PRC(442.8,"
+11 SET DA=PRCAS
+12 DO ^DIK
+13 QUIT
End DoDot:3
+14 IF PRCAS'>0
Begin DoDot:3
+15 SET DIC="^PRC(442.8,"
SET DIC(0)="L"
SET X=PAT
KILL DD,DO
DO FILE^DICN
IF Y'>0
WRITE !,"An error has occurred while restoring file 442.8 for "_PAT,!,",item "_PRCDS_"."
SET FLAG=1
QUIT
+16 SET PRCAS=$SELECT(PRCAS>0:PRCAS,1:+Y)
SET ^PRC(442.8,PRCAS,0)=PRCDATA
End DoDot:3
if FLAG>0
QUIT
+17 if FLAG>0
QUIT
+18 SET DIK="^PRC(442.8,"
SET DA=$SELECT(PRCAS>0:PRCAS,1:+Y)
DO IX^DIK
+19 SET PRCHIEN=0
FOR
SET PRCHIEN=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AD",PRCDSL,PRCHIEN))
if PRCHIEN=""
QUIT
SET $PIECE(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHIEN,0),U,7)=PRCAS
+20 QUIT
End DoDot:2
if FLAG>0
QUIT
+21 QUIT
End DoDot:1
if FLAG>0
QUIT
+22 if FLAG>0
QUIT
ROLL ;THIS WILL DO THE LINE ITEM ROLL-UP INTO ALL THE 'BOC's.
+1 SET LAST=0
SET %X="^PRC(442,PRCHPO,22,"
SET %Y="^PRC(443.6,PRCHPO,22,"
DO %XY^%RCR
+2 SET LOOP=0
FOR
SET LOOP=$ORDER(^PRC(442,PRCHPO,22,LOOP))
if LOOP'>0
QUIT
Begin DoDot:1
+3 SET LOOPVAL=$GET(^PRC(442,PRCHPO,22,LOOP,0))
SET $PIECE(LOOPVAL,U,2)=0
+4 SET ^PRC(442,PRCHPO,22,LOOP,0)=LOOPVAL
IF $PIECE(LOOPVAL,U,3)'=991
IF $PIECE(LOOPVAL,U,3)>LAST
SET LAST=$PIECE(LOOPVAL,U,3)
+5 QUIT
End DoDot:1
+6 SET DA=PRCHPO
DO ^PRCHAMYC
DO ^PRCHSF1
+7 SET (MESSG1,CHECKSUM)=""
DO RECODE^PRCHES5(PRCHPO,CHECKSUM,.MESSG1)
+8 ;
CLEANUP ;THE CODE FOLLOWING THIS COMMENT WILL DELETE THE TEMPORARY FILE
+1 ;ENTRIES IN FILE 443.6 AND 441.7 FOR PRCHPO ENTRY FROM 442 AND 442.8
+2 ;FILES.
+3 SET PRCHPO1=$PIECE($GET(^PRC(443.6,PRCHPO,0)),U)
SET PRCHPOX=$PIECE($GET(^PRC(443.6,PRCHPO,23)),U,4)
+4 IF PRCHPOX]""
SET PRCHPO2=$PIECE($GET(^PRC(443.6,PRCHPOX,0)),U)
+5 KILL ^PRC(443.6,PRCHPO)
IF PRCHPOX>0
KILL ^PRC(443.6,PRCHPOX)
+6 KILL ^PRC(443.6,"E",$PIECE(PRCHPO1,"-",2),PRCHPO),^PRC(443.6,"B",PRCHPO1,PRCHPO),^PRC(443.6,"D",PRCHPO),^PRC(443.6,"C",PRCHPO,PRCHAM)
+7 IF PRCHPOX>0
KILL ^PRC(443.6,"E",$PIECE(PRCHPO2,"-",2),PRCHPOX),^PRC(443.6,"B",PRCHPO2,PRCHPOX),^PRC(443.6,"D",PRCHPOX),^PRC(443.6,"C",PRCHPOX,PRCHAM)
+8 SET PRCDS=""
FOR
SET PRCDS=$ORDER(^PRC(441.7,"B",PRCHPO1,PRCDS))
if PRCDS'>0
QUIT
Begin DoDot:1
+9 SET DIK="^PRC(441.7,"
SET DA=PRCDS
DO ^DIK
+10 QUIT
End DoDot:1
+11 ;
STATUS ;NOW TO UPDATE THE 'SUPPLY STATUS', FIELD .5. THIS WILL UPDATE
+1 ;THE P.O. STATUS TO EQUAL THE LATEST AMENDMENT STATUS.
+2 SET STATUS=$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,1)),U,4)
SET DR=".5////^S X=STATUS"
SET DIE="^PRC(442,"
SET DA=PRCHPO
DO ^DIE
+3 SET PRCOPODA=PRCHPO_"^"_1_"^"_PRCHAM
+4 ; ...now generating the PHM transaction...
+5 ; set up & send PHM
DO NEW^PRCOEDI
+6 ; Create FPDS message for the AAC, PRC*5.1*79. Check if the order was
+7 ; amended but the total dollar amount did not. If there is a cancellation, then send the HL7 message.
+8 ;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.
+9 IF "1378"[$PIECE(^PRC(442,PRCHPO,1),U,7)
GOTO OUT1
+10 IF $PIECE(^PRC(442,PRCHPO,0),U,15)>0
IF $DATA(^PRC(442,PRCHPO,25))
IF $DATA(^PRC(442,PRCHPO,9,1,0))
Begin DoDot:1
+11 IF $DATA(^PRC(442,PRCHPO,6,0))
Begin DoDot:2
+12 SET PRCMN=$PIECE(^PRC(442,PRCHPO,6,0),U,3)
+13 IF $PIECE(^PRC(442,PRCHPO,6,PRCMN,0),U,3)=0
IF $PIECE(^PRC(442,PRCHPO,7),U,2)'=45
SET PRCQ=1
End DoDot:2
+14 ;D:$G(PRCQ)'=1 EN^DDIOL("...now generating the FPDS message for the AAC...","","!!"),EN^DDIOL(" ") PRC*5.1*220
+15 if $GET(PRCQ)'=1
DO AAC^PRCHAAC
End DoDot:1
+16 ; End of changes for PRC*5.1*79
OUT1 KILL PRCOPODA,PRCQ,PRCMN
+1 IF STATUS'=45
GOTO EXIT
+2 SET AUTH=$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,0)),U,4)
+3 if AUTH=""
GOTO EXIT
+4 if '((AUTH=5)!(AUTH=15))
GOTO UPDATE
+5 KILL AUTH,REF,REF1
GOTO EXIT
+6 ;
UPDATE ;UPDATE FILE 410 TO POINT TO THE CORRECT P.O.
+1 SET O0=$GET(^PRC(442,PRCHPO,0))
+2 SET O1=$GET(^PRC(442,PRCHPO,1))
+3 SET FCP=+$PIECE(O0,U)_+$PIECE(O0,U,3)
+4 SET PODATE=+$PIECE(O1,U,15)
+5 SET NEWPO=$PIECE($GET(^PRC(442,PRCHPO,23)),U,4)
+6 if NEWPO=""
GOTO FINI
+7 SET PRCOPODA=NEWPO_"^"_2_"^"_PRCHAM_"^"_PRCHPO
+8 ;...now generating PHA transaction...
+9 DO NEW^PRCOEDI
+10 KILL PRCOPODA
+11 SET LOOP=0
FOR
SET LOOP=$ORDER(^PRC(442,NEWPO,2,LOOP))
if LOOP'>0
QUIT
Begin DoDot:1
+12 SET L0=$GET(^PRC(442,NEWPO,2,LOOP,0))
+13 SET L2=$GET(^PRC(442,NEWPO,2,LOOP,2))
+14 SET L0=$PIECE(L0,U,10)
SET L2=$PIECE(L2,U,13)
+15 if L0=""!(L2="")
QUIT
+16 IF $PIECE(L0,U,5)>0
Begin DoDot:2
+17 SET IMF=$PIECE(L0,U,5)
+18 KILL ^PRC(441,IMF,4,FCP,1,PRCHPO,0)
+19 SET ^PRC(441,IMF,4,FCP,1,NEWPO,0)=NEWPO
+20 KILL ^PRC(441,IMF,4,FCP,1,"AC",9999999-PODATE,PRCHPO)
+21 SET ^PRC(441,IMF,4,FCP,1,"AC",9999999-PODATE,NEWPO)=""
+22 QUIT
End DoDot:2
+23 SET DA(1)=L0
SET DA=L2
SET DIE="^PRCS(410,"_DA(1)_",""IT"","
SET DR="9///^S X=NEWPO"
+24 DO ^DIE
+25 QUIT
End DoDot:1
+26 SET PRC2237=$PIECE($GET(^PRC(442,PRCHPO,0)),U,12)
if PRC2237'>0
GOTO FINI
+27 SET PRCCNS=$PIECE($PIECE($GET(^PRC(442,NEWPO,0)),U),"-",2)
+28 SET OLDCNS=$PIECE(^PRCS(410,PRC2237,4),U,5)
+29 KILL ^PRCS(410,"D",OLDCNS,PRC2237)
+30 SET $PIECE(^PRCS(410,PRC2237,4),U,5)=PRCCNS
+31 SET ^PRCS(410,"D",PRCCNS,PRC2237)=""
+32 SET $PIECE(^PRCS(410,PRC2237,10),U,3)=NEWPO
+33 SET MESSAGE=""
DO RECODE^PRCSC2(PRC2237,.MESSAGE)
+34 IF MESSAGE'=1
WRITE !,"An error has occurred while recoding an ESIG.",!
FINI KILL NEWPO,LOOP,L0,L2,DIE,DR,PRC2237,OLDCNS,PRCCNS,MESSAGE
EXIT GOTO OTHER^PRCHAMYD
