- 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 Jan 18, 2025@03:08:54 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