PRCHG ;ID/RSD,SF-ISC/TKW/DAP-PROCESS 2237 ;5/8/13 15:39
V ;;5.1;IFCAP;**81,167,174**;Oct 20, 2000;Build 23
;Per VHA Directive 2004-38, this routine should not be modified.
;
ES ;SIGN 2237 IN PPM
G Q:'$D(PRC("PER"))!('$D(PRC("SITE"))) I $S('$D(^VA(200,+PRC("PER"),400)):1,$P(^(400),U,1)=4:0,$P(^(400),U,1)=2:0,1:1) W !!,"You are not a Supply Accountable Officer !",$C(7) G Q
S P=+PRC("PER"),DA=1,PRCSIG="" D ESIG^PRCUESIG(DUZ,.PRCSIG) S ROUTINE="PRCUESIG" G:PRCSIG'=1 QQ S PRCHNM=$P(^VA(200,P,20),U,2)
Q
;
ES1 ;S PRCHG=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:""),$P(^PRC(443,DA,0),"^",3)="",P=+PRC("PER")
S PRCHG=$P($G(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)),U,2),$P(^PRC(443,DA,0),"^",3)="",P=+PRC("PER")
I PRCHG=63 S PRCFA("WHO")=3 D RET
N DA2237 S DA2237=DA
;
;if PO is not for PPM Clerk stop processing and exit
I PRCHG<65 K PRCHG Q
S PRCSIG="" D ENCODE^PRCHES11(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ
;set AO name, signature date on 2237 record
I $D(DA2237) L +^PRCS(410,DA2237):15 Q:'$T D NOW^%DTC S $P(^PRCS(410,DA2237,7),"^",11)=P,$P(^PRCS(410,DA2237,7),"^",12)=% L -^PRCS(410,DA2237)
;
;if 2237 status is 'Sent to eCMS(P&C)', transmit to eCMS via HL7 msg OMN^O07 (PRC*5.1*167)
N PRCER ;transmission error msg
N PRCEVNT ;event array for LOG^PRCHJTA
I PRCHG=69 D
. N PRCLOGER ;error returned from LOG^PRCHJTA
. N PRCMSGID ;ien of msg in HLO MESSAGES (#778)
. W !!,"Transmitting 2237 transaction to eCMS..."
. S PRCMSGID=$$SEND2237^PRCHJS01($G(DA2237),.PRCER)
. ;
. ;was the transmission successful, ELSE did it fail?
. I $G(PRCMSGID)>0 D
. . W !?3,">>> 2237 transaction has been successfully transmitted to eCMS."
. . W !?7,"Transaction Number: "_$G(PRCTRANS)
. . W !?11,"HLO Message ID: "_$G(PRCMSGID)
. . W !!?3,">>> Updating transmission in IFCAP/ECMS Transaction file..."
. . S PRCEVNT("MSGID")=$G(PRCMSGID)
. . S PRCEVNT("IEN410")=$G(DA2237)
. . S PRCEVNT("IFCAPU")=$G(DUZ)
. . D LOG^PRCHJTA($G(PRCTRANS),,1,.PRCEVNT,.PRCLOGER)
. . I +$G(PRCLOGER) W !?7,"Error: "_$P($G(PRCLOGER),U,2)
. E D
. . W !?3,">>> ERROR: 2237 was not transmitted to eCMS!"
. . W !?7,"Transaction Number: "_$G(PRCTRANS)
. . ;setup PRCEVNT array for call to LOG^PRCHJTA and output error(s)
. . S PRCEVNT("MSGID")=""
. . S PRCEVNT("IEN410")=$G(DA2237)
. . S PRCEVNT("IFCAPU")=$G(DUZ)
. . S PRCEVNT("ERROR",1)="An error occurred when transmitting the 2237 transaction to eCMS."
. . S PRCEVNT("ERROR",2)="Option: "_$S($P($G(XQY0),"^",2)]"":$P($G(XQY0),"^",2),1:"UNKNOWN")
. . N PRCIDX1,PRCIDX2
. . S PRCIDX1=0,PRCIDX2=2
. . ;output error(s)
. . F S PRCIDX1=$O(PRCER(PRCIDX1)) Q:PRCIDX1="" D
. . . W !?7,"Error #"_$G(PRCIDX1)_": "_$G(PRCER(PRCIDX1))
. . . S PRCIDX2=PRCIDX2+1 S PRCEVNT("ERROR",PRCIDX2)="Error #"_$G(PRCIDX1)_": "_$G(PRCER(PRCIDX1))
. . W !!?3,">>> Updating transmission error in IFCAP/ECMS Transaction file..."
. . D LOG^PRCHJTA($G(PRCTRANS),,1,.PRCEVNT,.PRCLOGER)
. . I +$G(PRCLOGER) W !?7,"Error: "_$P($G(PRCLOGER),U,2)
. . ;send error(s) to AO
. . W !!?3,">>> Sending error notification mail message to Accountable Officer..."
. . N PRCMSG1,PRCMSG2 ;input arrays for PHMSG^PRCHJMSG, pass by ref
. . S PRCMSG1(1)=$G(PRCTRANS) ;2237 transaction #
. . S PRCMSG1(2)=5 ;return to AO since failed transmission to eCMS
. . S PRCMSG1(3)=$$NOW^XLFDT ;action date/time
. . S PRCMSG1(7)="Please forward this message to appropriate OIT staff!"
. . M PRCMSG2=PRCEVNT("ERROR") ;merge error array into PRCMSG2 array
. . D PHMSG^PRCHJMSG(.PRCMSG1,.PRCMSG2) ;send msg
;
Q
;
QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR
;
Q K %,DA,DIC,DIE,DR,P,PRCHNM,PRCHTDA,PRCHG,PRCHPO,PRCHS,PRCHSIT,PRCHSX,PRCHSY,PRCHSZ,PRCHX,PRCTRANS,ROUTINE
Q
;
RET ;RETURN TO SERVICE--UPDATE CP BALANCES, ERASE CP OFFICIAL SIGNATURE, SEND BULLETIN BACK TO SERVICE
S PRCHDA=DA,X=$P(^PRCS(410,DA,4),"^",8) D TRANK^PRCSES S $P(^PRCS(410,DA,7),"^",5,7)="^^",$P(^PRCS(410,DA,10),U,4)=$P(^PRC(443,DA,0),U,7),DIE="^PRCS(410,",DR=61 D ^DIE K DIE
S DA=PRCHDA D REMOVE^PRCSC1(DA),REMOVE^PRCSC3(DA)
;remove AO name, signature date from 2237 record
N PPMNODE F PPMNODE=11,12 S $P(^PRCS(410,DA,7),"^",PPMNODE)=""
S (DA,PRCFA("TRDA"))=PRCHDA D RETURN^PRCEFIS1 S DA=PRCHDA D EN3^PRCPWI
Q
;
SIT S PRCF("X")="SP" D ^PRCFSITE K PRCHNM
Q
;
TR S DIC("S")="I $P(^(0),U,3)="""",$D(^PRCS(410,Y,7)),$P(^(7),U,6)]"""",+^(0)=PRC(""SITE"")"
S DIC("S")=$S('$D(PRCFDICS):DIC("S")_" S Z=$O(^PRCD(442.3,""C"",+$P(^PRC(443,Y,0),U,7),0)) I Z'=10&(Z'=85)",1:DIC("S")_PRCFDICS)
;
DIC W !! K DA S DIC="^PRC(443,",DIC(0)="QEAMZ",DIC("A")="2237 TRANSACTION NUMBER: " D ^DIC S DIE=DIC K DIC S:Y>0 DA=+Y,PRCTRANS=$G(Y(0,0))
Q
;
ST S DIC("S")="I $P(^(0),U,3)]"""",$O(^PRCD(442.3,""C"",+$P(^(0),U,7),0))'=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE"")" D DIC
Q
;
PPM S DR="[PRCHPPM]",DIE("NO^")="" D ^DIE K DIE,PRCHPPM D ES1
Q
;
EN ;SIGN 2237 IN PPM
D SIT Q:'$D(PRC("SITE")) D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q
;*81 Check site parameter to see if issue books should be allowed
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 D EN^PRCHG1
;
EN0 D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q D TR G:'$D(DA) Q D PPM
G EN0
;
EN1 ;SIGN 2237 IN PC
D SIT Q:'$D(PRC("SITE"))
EN10 D ST G:'$D(DA) Q S DR="[PRCHPC]",DIE("NO^")="" D ^DIE K DIE
G EN10
;
EN2 ;RETURN 2237 IN PC
D SIT Q:'$D(PRC("SITE"))
EN20 ;D ST G:'$D(DA) Q S DR="[PRCHPCR]" D ^DIE K PRCHPCR S Z=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:"") G:Z'=76 EN20
D ST G:'$D(DA) Q S DR="[PRCHPCR]" D ^DIE K PRCHPCR S Z=$P($G(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)),U,2) G:Z'=76 EN20
S $P(^PRC(443,DA,0),"^",2,4)="^^"
S PRCFA("WHO")=2 D RET
G EN20
;
EN3 ;SPLIT 2237 IN PPM
D SIT Q:'$D(PRC("SITE"))
EN30 D TR G:'$D(DA) Q S PRCHSY(0)=Y(0),(PRCHPO,PRCHSY)=DA,(PRCHG,PRCHSZ)=1 D N^PRCHNPO3 G Q:'$D(PRCHSY)!('$O(^TMP($J,"PRCHS",0))),W1:+^TMP($J,"PRCHS",0)=+^PRCS(410,DA,10)
S PRCHSIT=+^TMP($J,"PRCHS",0),PRCHS=PRCHSY D WAIT^DICD,^PRCHSP I PRCHSY=-1 D ERR^PRCHNPO3,Q G EN30
W !!,"The new 2237, ",PRCHSX,", will now be printed with the old one." F DA=PRCHS,PRCHSY S PRCSF=1 D PRF1^PRCSP1
K PRCSF D Q
G EN30
;
EN4 ;EDIT A SIGNED 2237 IN PPM
D SIT Q:'$D(PRC("SITE"))
EN40 D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q S DIC("S")="I $P(^(0),U,3)]""""" D DIC G:'$D(DA) Q D PPM
G EN40
;
EN5 ;DISPLAY NO.OF REQUESTS TO BE PROCESSED BY PPM
S X=0 F I=0:0 S I=$O(^PRC(443,"AC",60,I)) Q:'I S X=X+1
W $C(7),!!!,?3,"There are "_X_" Requests ready to process." K X,I
Q
;
W1 W !!,"You have selected all Line Items, NO action taken.",$C(7) D Q
G EN3
;
STAT I $D(PRCFGPF) S DIC("S")="S Z=$P(^(0),U,2) I Z=10!(Z=60)!(Z=85)" Q
I $D(PRCHPCR) D Q
. S DIC("S")="I $P(^(0),U,2)=75!($P(^(0),U,2)=76)"
. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D Q
. . N PRC2237
. . S PRC2237=$P(^PRCS(410,DA,0),"^",1)
. . I '$$CHKDM^PRCVLIC(PRC2237) Q
. . I $O(^PRCS(410,"AG",PRC2237,""))]"" S DIC("S")="I $P(^(0),U,2)=75"
I '$D(PRCHPPM) S DIC("S")="I $P(^(0),U,2)>69" Q
K Z0 S (Z0(60),Z0(62),Z0(63),Z0(65),Z0(74))="" S:$P(^PRC(443,DA,0),U,10)=4 Z0(70)="",Z0(69)=""
S DIC("S")="I $D(Z0(+$P(^(0),U,2)))"
S:$$ECMS2237^PRCHJUTL(DA) DIC("S")="I "";60;63;69;""[("";""_$P(^(0),U,2)_"";"")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHG 7464 printed Sep 02, 2024@18:53 Page 2
PRCHG ;ID/RSD,SF-ISC/TKW/DAP-PROCESS 2237 ;5/8/13 15:39
V ;;5.1;IFCAP;**81,167,174**;Oct 20, 2000;Build 23
+1 ;Per VHA Directive 2004-38, this routine should not be modified.
+2 ;
ES ;SIGN 2237 IN PPM
+1 if '$DATA(PRC("PER"))!('$DATA(PRC("SITE")))
GOTO Q
IF $SELECT('$DATA(^VA(200,+PRC("PER"),400)):1,$PIECE(^(400),U,1)=4:0,$PIECE(^(400),U,1)=2:0,1:1)
WRITE !!,"You are not a Supply Accountable Officer !",$CHAR(7)
GOTO Q
+2 SET P=+PRC("PER")
SET DA=1
SET PRCSIG=""
DO ESIG^PRCUESIG(DUZ,.PRCSIG)
SET ROUTINE="PRCUESIG"
if PRCSIG'=1
GOTO QQ
SET PRCHNM=$PIECE(^VA(200,P,20),U,2)
+3 QUIT
+4 ;
ES1 ;S PRCHG=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:""),$P(^PRC(443,DA,0),"^",3)="",P=+PRC("PER")
+1 SET PRCHG=$PIECE($GET(^PRCD(442.3,+$PIECE(^PRC(443,DA,0),U,7),0)),U,2)
SET $PIECE(^PRC(443,DA,0),"^",3)=""
SET P=+PRC("PER")
+2 IF PRCHG=63
SET PRCFA("WHO")=3
DO RET
+3 NEW DA2237
SET DA2237=DA
+4 ;
+5 ;if PO is not for PPM Clerk stop processing and exit
+6 IF PRCHG<65
KILL PRCHG
QUIT
+7 SET PRCSIG=""
DO ENCODE^PRCHES11(DA,DUZ,.PRCSIG)
SET ROUTINE=$TEXT(+0)
if PRCSIG<1
GOTO QQ
+8 ;set AO name, signature date on 2237 record
+9 IF $DATA(DA2237)
LOCK +^PRCS(410,DA2237):15
if '$TEST
QUIT
DO NOW^%DTC
SET $PIECE(^PRCS(410,DA2237,7),"^",11)=P
SET $PIECE(^PRCS(410,DA2237,7),"^",12)=%
LOCK -^PRCS(410,DA2237)
+10 ;
+11 ;if 2237 status is 'Sent to eCMS(P&C)', transmit to eCMS via HL7 msg OMN^O07 (PRC*5.1*167)
+12 ;transmission error msg
NEW PRCER
+13 ;event array for LOG^PRCHJTA
NEW PRCEVNT
+14 IF PRCHG=69
Begin DoDot:1
+15 ;error returned from LOG^PRCHJTA
NEW PRCLOGER
+16 ;ien of msg in HLO MESSAGES (#778)
NEW PRCMSGID
+17 WRITE !!,"Transmitting 2237 transaction to eCMS..."
+18 SET PRCMSGID=$$SEND2237^PRCHJS01($GET(DA2237),.PRCER)
+19 ;
+20 ;was the transmission successful, ELSE did it fail?
+21 IF $GET(PRCMSGID)>0
Begin DoDot:2
+22 WRITE !?3,">>> 2237 transaction has been successfully transmitted to eCMS."
+23 WRITE !?7,"Transaction Number: "_$GET(PRCTRANS)
+24 WRITE !?11,"HLO Message ID: "_$GET(PRCMSGID)
+25 WRITE !!?3,">>> Updating transmission in IFCAP/ECMS Transaction file..."
+26 SET PRCEVNT("MSGID")=$GET(PRCMSGID)
+27 SET PRCEVNT("IEN410")=$GET(DA2237)
+28 SET PRCEVNT("IFCAPU")=$GET(DUZ)
+29 DO LOG^PRCHJTA($GET(PRCTRANS),,1,.PRCEVNT,.PRCLOGER)
+30 IF +$GET(PRCLOGER)
WRITE !?7,"Error: "_$PIECE($GET(PRCLOGER),U,2)
End DoDot:2
+31 IF '$TEST
Begin DoDot:2
+32 WRITE !?3,">>> ERROR: 2237 was not transmitted to eCMS!"
+33 WRITE !?7,"Transaction Number: "_$GET(PRCTRANS)
+34 ;setup PRCEVNT array for call to LOG^PRCHJTA and output error(s)
+35 SET PRCEVNT("MSGID")=""
+36 SET PRCEVNT("IEN410")=$GET(DA2237)
+37 SET PRCEVNT("IFCAPU")=$GET(DUZ)
+38 SET PRCEVNT("ERROR",1)="An error occurred when transmitting the 2237 transaction to eCMS."
+39 SET PRCEVNT("ERROR",2)="Option: "_$SELECT($PIECE($GET(XQY0),"^",2)]"":$PIECE($GET(XQY0),"^",2),1:"UNKNOWN")
+40 NEW PRCIDX1,PRCIDX2
+41 SET PRCIDX1=0
SET PRCIDX2=2
+42 ;output error(s)
+43 FOR
SET PRCIDX1=$ORDER(PRCER(PRCIDX1))
if PRCIDX1=""
QUIT
Begin DoDot:3
+44 WRITE !?7,"Error #"_$GET(PRCIDX1)_": "_$GET(PRCER(PRCIDX1))
+45 SET PRCIDX2=PRCIDX2+1
SET PRCEVNT("ERROR",PRCIDX2)="Error #"_$GET(PRCIDX1)_": "_$GET(PRCER(PRCIDX1))
End DoDot:3
+46 WRITE !!?3,">>> Updating transmission error in IFCAP/ECMS Transaction file..."
+47 DO LOG^PRCHJTA($GET(PRCTRANS),,1,.PRCEVNT,.PRCLOGER)
+48 IF +$GET(PRCLOGER)
WRITE !?7,"Error: "_$PIECE($GET(PRCLOGER),U,2)
+49 ;send error(s) to AO
+50 WRITE !!?3,">>> Sending error notification mail message to Accountable Officer..."
+51 ;input arrays for PHMSG^PRCHJMSG, pass by ref
NEW PRCMSG1,PRCMSG2
+52 ;2237 transaction #
SET PRCMSG1(1)=$GET(PRCTRANS)
+53 ;return to AO since failed transmission to eCMS
SET PRCMSG1(2)=5
+54 ;action date/time
SET PRCMSG1(3)=$$NOW^XLFDT
+55 SET PRCMSG1(7)="Please forward this message to appropriate OIT staff!"
+56 ;merge error array into PRCMSG2 array
MERGE PRCMSG2=PRCEVNT("ERROR")
+57 ;send msg
DO PHMSG^PRCHJMSG(.PRCMSG1,.PRCMSG2)
End DoDot:2
End DoDot:1
+58 ;
+59 QUIT
+60 ;
QQ if '$DATA(ROUTINE)
SET ROUTINE=$TEXT(+0)
WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
if PRCSIG=0!(PRCSIG=-3)
WRITE !,"Notify Application Coordinator!",$CHAR(7)
SET DIR(0)="EAO"
SET DIR("A")="Press <return> to continue"
DO ^DIR
+1 ;
Q KILL %,DA,DIC,DIE,DR,P,PRCHNM,PRCHTDA,PRCHG,PRCHPO,PRCHS,PRCHSIT,PRCHSX,PRCHSY,PRCHSZ,PRCHX,PRCTRANS,ROUTINE
+1 QUIT
+2 ;
RET ;RETURN TO SERVICE--UPDATE CP BALANCES, ERASE CP OFFICIAL SIGNATURE, SEND BULLETIN BACK TO SERVICE
+1 SET PRCHDA=DA
SET X=$PIECE(^PRCS(410,DA,4),"^",8)
DO TRANK^PRCSES
SET $PIECE(^PRCS(410,DA,7),"^",5,7)="^^"
SET $PIECE(^PRCS(410,DA,10),U,4)=$PIECE(^PRC(443,DA,0),U,7)
SET DIE="^PRCS(410,"
SET DR=61
DO ^DIE
KILL DIE
+2 SET DA=PRCHDA
DO REMOVE^PRCSC1(DA)
DO REMOVE^PRCSC3(DA)
+3 ;remove AO name, signature date from 2237 record
+4 NEW PPMNODE
FOR PPMNODE=11,12
SET $PIECE(^PRCS(410,DA,7),"^",PPMNODE)=""
+5 SET (DA,PRCFA("TRDA"))=PRCHDA
DO RETURN^PRCEFIS1
SET DA=PRCHDA
DO EN3^PRCPWI
+6 QUIT
+7 ;
SIT SET PRCF("X")="SP"
DO ^PRCFSITE
KILL PRCHNM
+1 QUIT
+2 ;
TR SET DIC("S")="I $P(^(0),U,3)="""",$D(^PRCS(410,Y,7)),$P(^(7),U,6)]"""",+^(0)=PRC(""SITE"")"
+1 SET DIC("S")=$SELECT('$DATA(PRCFDICS):DIC("S")_" S Z=$O(^PRCD(442.3,""C"",+$P(^PRC(443,Y,0),U,7),0)) I Z'=10&(Z'=85)",1:DIC("S")_PRCFDICS)
+2 ;
DIC WRITE !!
KILL DA
SET DIC="^PRC(443,"
SET DIC(0)="QEAMZ"
SET DIC("A")="2237 TRANSACTION NUMBER: "
DO ^DIC
SET DIE=DIC
KILL DIC
if Y>0
SET DA=+Y
SET PRCTRANS=$GET(Y(0,0))
+1 QUIT
+2 ;
ST SET DIC("S")="I $P(^(0),U,3)]"""",$O(^PRCD(442.3,""C"",+$P(^(0),U,7),0))'=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE"")"
DO DIC
+1 QUIT
+2 ;
PPM SET DR="[PRCHPPM]"
SET DIE("NO^")=""
DO ^DIE
KILL DIE,PRCHPPM
DO ES1
+1 QUIT
+2 ;
EN ;SIGN 2237 IN PPM
+1 DO SIT
if '$DATA(PRC("SITE"))
QUIT
if '$DATA(PRCHNM)
DO ES
if '$DATA(PRCHNM)
GOTO Q
+2 ;*81 Check site parameter to see if issue books should be allowed
+3 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
DO EN^PRCHG1
+4 ;
EN0 if '$DATA(PRCHNM)
DO ES
if '$DATA(PRCHNM)
GOTO Q
DO TR
if '$DATA(DA)
GOTO Q
DO PPM
+1 GOTO EN0
+2 ;
EN1 ;SIGN 2237 IN PC
+1 DO SIT
if '$DATA(PRC("SITE"))
QUIT
EN10 DO ST
if '$DATA(DA)
GOTO Q
SET DR="[PRCHPC]"
SET DIE("NO^")=""
DO ^DIE
KILL DIE
+1 GOTO EN10
+2 ;
EN2 ;RETURN 2237 IN PC
+1 DO SIT
if '$DATA(PRC("SITE"))
QUIT
EN20 ;D ST G:'$D(DA) Q S DR="[PRCHPCR]" D ^DIE K PRCHPCR S Z=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:"") G:Z'=76 EN20
+1 DO ST
if '$DATA(DA)
GOTO Q
SET DR="[PRCHPCR]"
DO ^DIE
KILL PRCHPCR
SET Z=$PIECE($GET(^PRCD(442.3,+$PIECE(^PRC(443,DA,0),U,7),0)),U,2)
if Z'=76
GOTO EN20
+2 SET $PIECE(^PRC(443,DA,0),"^",2,4)="^^"
+3 SET PRCFA("WHO")=2
DO RET
+4 GOTO EN20
+5 ;
EN3 ;SPLIT 2237 IN PPM
+1 DO SIT
if '$DATA(PRC("SITE"))
QUIT
EN30 DO TR
if '$DATA(DA)
GOTO Q
SET PRCHSY(0)=Y(0)
SET (PRCHPO,PRCHSY)=DA
SET (PRCHG,PRCHSZ)=1
DO N^PRCHNPO3
if '$DATA(PRCHSY)!('$ORDER(^TMP($JOB,"PRCHS",0)))
GOTO Q
if +^TMP($JOB,"PRCHS",0)=+^PRCS(410,DA,10)
GOTO W1
+1 SET PRCHSIT=+^TMP($JOB,"PRCHS",0)
SET PRCHS=PRCHSY
DO WAIT^DICD
DO ^PRCHSP
IF PRCHSY=-1
DO ERR^PRCHNPO3
DO Q
GOTO EN30
+2 WRITE !!,"The new 2237, ",PRCHSX,", will now be printed with the old one."
FOR DA=PRCHS,PRCHSY
SET PRCSF=1
DO PRF1^PRCSP1
+3 KILL PRCSF
DO Q
+4 GOTO EN30
+5 ;
EN4 ;EDIT A SIGNED 2237 IN PPM
+1 DO SIT
if '$DATA(PRC("SITE"))
QUIT
EN40 if '$DATA(PRCHNM)
DO ES
if '$DATA(PRCHNM)
GOTO Q
SET DIC("S")="I $P(^(0),U,3)]"""""
DO DIC
if '$DATA(DA)
GOTO Q
DO PPM
+1 GOTO EN40
+2 ;
EN5 ;DISPLAY NO.OF REQUESTS TO BE PROCESSED BY PPM
+1 SET X=0
FOR I=0:0
SET I=$ORDER(^PRC(443,"AC",60,I))
if 'I
QUIT
SET X=X+1
+2 WRITE $CHAR(7),!!!,?3,"There are "_X_" Requests ready to process."
KILL X,I
+3 QUIT
+4 ;
W1 WRITE !!,"You have selected all Line Items, NO action taken.",$CHAR(7)
DO Q
+1 GOTO EN3
+2 ;
STAT IF $DATA(PRCFGPF)
SET DIC("S")="S Z=$P(^(0),U,2) I Z=10!(Z=60)!(Z=85)"
QUIT
+1 IF $DATA(PRCHPCR)
Begin DoDot:1
+2 SET DIC("S")="I $P(^(0),U,2)=75!($P(^(0),U,2)=76)"
+3 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
Begin DoDot:2
+4 NEW PRC2237
+5 SET PRC2237=$PIECE(^PRCS(410,DA,0),"^",1)
+6 IF '$$CHKDM^PRCVLIC(PRC2237)
QUIT
+7 IF $ORDER(^PRCS(410,"AG",PRC2237,""))]""
SET DIC("S")="I $P(^(0),U,2)=75"
End DoDot:2
QUIT
End DoDot:1
QUIT
+8 IF '$DATA(PRCHPPM)
SET DIC("S")="I $P(^(0),U,2)>69"
QUIT
+9 KILL Z0
SET (Z0(60),Z0(62),Z0(63),Z0(65),Z0(74))=""
if $PIECE(^PRC(443,DA,0),U,10)=4
SET Z0(70)=""
SET Z0(69)=""
+10 SET DIC("S")="I $D(Z0(+$P(^(0),U,2)))"
+11 if $$ECMS2237^PRCHJUTL(DA)
SET DIC("S")="I "";60;63;69;""[("";""_$P(^(0),U,2)_"";"")"
+12 QUIT
