Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHG

PRCHG.m

Go to the documentation of this file.
  1. PRCHG ;ID/RSD,SF-ISC/TKW/DAP-PROCESS 2237 ;5/8/13 15:39
  1. V ;;5.1;IFCAP;**81,167,174**;Oct 20, 2000;Build 23
  1. ;Per VHA Directive 2004-38, this routine should not be modified.
  1. ;
  1. ES ;SIGN 2237 IN PPM
  1. 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
  1. 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)
  1. Q
  1. ;
  1. 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. 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")
  1. I PRCHG=63 S PRCFA("WHO")=3 D RET
  1. N DA2237 S DA2237=DA
  1. ;
  1. ;if PO is not for PPM Clerk stop processing and exit
  1. I PRCHG<65 K PRCHG Q
  1. S PRCSIG="" D ENCODE^PRCHES11(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ
  1. ;set AO name, signature date on 2237 record
  1. 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)
  1. ;
  1. ;if 2237 status is 'Sent to eCMS(P&C)', transmit to eCMS via HL7 msg OMN^O07 (PRC*5.1*167)
  1. N PRCER ;transmission error msg
  1. N PRCEVNT ;event array for LOG^PRCHJTA
  1. I PRCHG=69 D
  1. . N PRCLOGER ;error returned from LOG^PRCHJTA
  1. . N PRCMSGID ;ien of msg in HLO MESSAGES (#778)
  1. . W !!,"Transmitting 2237 transaction to eCMS..."
  1. . S PRCMSGID=$$SEND2237^PRCHJS01($G(DA2237),.PRCER)
  1. . ;
  1. . ;was the transmission successful, ELSE did it fail?
  1. . I $G(PRCMSGID)>0 D
  1. . . W !?3,">>> 2237 transaction has been successfully transmitted to eCMS."
  1. . . W !?7,"Transaction Number: "_$G(PRCTRANS)
  1. . . W !?11,"HLO Message ID: "_$G(PRCMSGID)
  1. . . W !!?3,">>> Updating transmission in IFCAP/ECMS Transaction file..."
  1. . . S PRCEVNT("MSGID")=$G(PRCMSGID)
  1. . . S PRCEVNT("IEN410")=$G(DA2237)
  1. . . S PRCEVNT("IFCAPU")=$G(DUZ)
  1. . . D LOG^PRCHJTA($G(PRCTRANS),,1,.PRCEVNT,.PRCLOGER)
  1. . . I +$G(PRCLOGER) W !?7,"Error: "_$P($G(PRCLOGER),U,2)
  1. . E D
  1. . . W !?3,">>> ERROR: 2237 was not transmitted to eCMS!"
  1. . . W !?7,"Transaction Number: "_$G(PRCTRANS)
  1. . . ;setup PRCEVNT array for call to LOG^PRCHJTA and output error(s)
  1. . . S PRCEVNT("MSGID")=""
  1. . . S PRCEVNT("IEN410")=$G(DA2237)
  1. . . S PRCEVNT("IFCAPU")=$G(DUZ)
  1. . . S PRCEVNT("ERROR",1)="An error occurred when transmitting the 2237 transaction to eCMS."
  1. . . S PRCEVNT("ERROR",2)="Option: "_$S($P($G(XQY0),"^",2)]"":$P($G(XQY0),"^",2),1:"UNKNOWN")
  1. . . N PRCIDX1,PRCIDX2
  1. . . S PRCIDX1=0,PRCIDX2=2
  1. . . ;output error(s)
  1. . . F S PRCIDX1=$O(PRCER(PRCIDX1)) Q:PRCIDX1="" D
  1. . . . W !?7,"Error #"_$G(PRCIDX1)_": "_$G(PRCER(PRCIDX1))
  1. . . . S PRCIDX2=PRCIDX2+1 S PRCEVNT("ERROR",PRCIDX2)="Error #"_$G(PRCIDX1)_": "_$G(PRCER(PRCIDX1))
  1. . . W !!?3,">>> Updating transmission error in IFCAP/ECMS Transaction file..."
  1. . . D LOG^PRCHJTA($G(PRCTRANS),,1,.PRCEVNT,.PRCLOGER)
  1. . . I +$G(PRCLOGER) W !?7,"Error: "_$P($G(PRCLOGER),U,2)
  1. . . ;send error(s) to AO
  1. . . W !!?3,">>> Sending error notification mail message to Accountable Officer..."
  1. . . N PRCMSG1,PRCMSG2 ;input arrays for PHMSG^PRCHJMSG, pass by ref
  1. . . S PRCMSG1(1)=$G(PRCTRANS) ;2237 transaction #
  1. . . S PRCMSG1(2)=5 ;return to AO since failed transmission to eCMS
  1. . . S PRCMSG1(3)=$$NOW^XLFDT ;action date/time
  1. . . S PRCMSG1(7)="Please forward this message to appropriate OIT staff!"
  1. . . M PRCMSG2=PRCEVNT("ERROR") ;merge error array into PRCMSG2 array
  1. . . D PHMSG^PRCHJMSG(.PRCMSG1,.PRCMSG2) ;send msg
  1. ;
  1. Q
  1. ;
  1. 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
  1. ;
  1. Q K %,DA,DIC,DIE,DR,P,PRCHNM,PRCHTDA,PRCHG,PRCHPO,PRCHS,PRCHSIT,PRCHSX,PRCHSY,PRCHSZ,PRCHX,PRCTRANS,ROUTINE
  1. Q
  1. ;
  1. RET ;RETURN TO SERVICE--UPDATE CP BALANCES, ERASE CP OFFICIAL SIGNATURE, SEND BULLETIN BACK TO SERVICE
  1. 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
  1. S DA=PRCHDA D REMOVE^PRCSC1(DA),REMOVE^PRCSC3(DA)
  1. ;remove AO name, signature date from 2237 record
  1. N PPMNODE F PPMNODE=11,12 S $P(^PRCS(410,DA,7),"^",PPMNODE)=""
  1. S (DA,PRCFA("TRDA"))=PRCHDA D RETURN^PRCEFIS1 S DA=PRCHDA D EN3^PRCPWI
  1. Q
  1. ;
  1. SIT S PRCF("X")="SP" D ^PRCFSITE K PRCHNM
  1. Q
  1. ;
  1. TR S DIC("S")="I $P(^(0),U,3)="""",$D(^PRCS(410,Y,7)),$P(^(7),U,6)]"""",+^(0)=PRC(""SITE"")"
  1. 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)
  1. ;
  1. 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))
  1. Q
  1. ;
  1. 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
  1. Q
  1. ;
  1. PPM S DR="[PRCHPPM]",DIE("NO^")="" D ^DIE K DIE,PRCHPPM D ES1
  1. Q
  1. ;
  1. EN ;SIGN 2237 IN PPM
  1. D SIT Q:'$D(PRC("SITE")) D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q
  1. ;*81 Check site parameter to see if issue books should be allowed
  1. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 D EN^PRCHG1
  1. ;
  1. EN0 D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q D TR G:'$D(DA) Q D PPM
  1. G EN0
  1. ;
  1. EN1 ;SIGN 2237 IN PC
  1. D SIT Q:'$D(PRC("SITE"))
  1. EN10 D ST G:'$D(DA) Q S DR="[PRCHPC]",DIE("NO^")="" D ^DIE K DIE
  1. G EN10
  1. ;
  1. EN2 ;RETURN 2237 IN PC
  1. D SIT Q:'$D(PRC("SITE"))
  1. 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. 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
  1. S $P(^PRC(443,DA,0),"^",2,4)="^^"
  1. S PRCFA("WHO")=2 D RET
  1. G EN20
  1. ;
  1. EN3 ;SPLIT 2237 IN PPM
  1. D SIT Q:'$D(PRC("SITE"))
  1. 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)
  1. S PRCHSIT=+^TMP($J,"PRCHS",0),PRCHS=PRCHSY D WAIT^DICD,^PRCHSP I PRCHSY=-1 D ERR^PRCHNPO3,Q G EN30
  1. W !!,"The new 2237, ",PRCHSX,", will now be printed with the old one." F DA=PRCHS,PRCHSY S PRCSF=1 D PRF1^PRCSP1
  1. K PRCSF D Q
  1. G EN30
  1. ;
  1. EN4 ;EDIT A SIGNED 2237 IN PPM
  1. D SIT Q:'$D(PRC("SITE"))
  1. 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
  1. G EN40
  1. ;
  1. EN5 ;DISPLAY NO.OF REQUESTS TO BE PROCESSED BY PPM
  1. S X=0 F I=0:0 S I=$O(^PRC(443,"AC",60,I)) Q:'I S X=X+1
  1. W $C(7),!!!,?3,"There are "_X_" Requests ready to process." K X,I
  1. Q
  1. ;
  1. W1 W !!,"You have selected all Line Items, NO action taken.",$C(7) D Q
  1. G EN3
  1. ;
  1. STAT I $D(PRCFGPF) S DIC("S")="S Z=$P(^(0),U,2) I Z=10!(Z=60)!(Z=85)" Q
  1. I $D(PRCHPCR) D Q
  1. . S DIC("S")="I $P(^(0),U,2)=75!($P(^(0),U,2)=76)"
  1. . I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D Q
  1. . . N PRC2237
  1. . . S PRC2237=$P(^PRCS(410,DA,0),"^",1)
  1. . . I '$$CHKDM^PRCVLIC(PRC2237) Q
  1. . . I $O(^PRCS(410,"AG",PRC2237,""))]"" S DIC("S")="I $P(^(0),U,2)=75"
  1. I '$D(PRCHPPM) S DIC("S")="I $P(^(0),U,2)>69" Q
  1. 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)=""
  1. S DIC("S")="I $D(Z0(+$P(^(0),U,2)))"
  1. S:$$ECMS2237^PRCHJUTL(DA) DIC("S")="I "";60;63;69;""[("";""_$P(^(0),U,2)_"";"")"
  1. Q