PRCHJRP5 ;OI&T/DDA - Transaction Report from 414.06 ;3/22/13 13:48
;;5.1;IFCAP;**174**;Oct 20,2000;Build 23
;Per VHA Directive 2004-38, this routine should not be modified.
;
Q
EN ;Revised Transaction Report
;setup user data
K XQORNOD D OP^XQCHK
S PRCHOPT=$S($P(XQOPT,"^")="PRCHJ TRANS REPORT":1,$P(XQOPT,"^")="PRCHJ TRANS REPORT2":2,$P(XQOPT,"^")="PRCHJ TRANS REPORT3":3,1:0)
I PRCHOPT=0 W !!,"REPORT MUST BE RUN FROM APPROPRIATE MENU OPTIONS." Q
S:$G(PRCHEMP)="" PRCHEMP=$$GET1^DIQ(200,DUZ_",",400,"I")
I PRCHOPT=1 I '((PRCHEMP=2)!(PRCHEMP=4)) W !!,"You are not a PPM Accountable Officer or Manager!" Q
EN2 ;
D USERFCP
I PRCHURSN=0 W !!,"You do not have access to any Fund Control Points!" Q
ENSING ;prompt for a single 2237
K DIR
S PRCH2237=0
S DIR("A")="Select a single 2237 TRANSACTION NUMBER"
S DIR(0)="Y",DIR("B")="NO" D ^DIR
;If YES go to lookup and display for a single 2237.
I Y=1 K DIR D SINGLE I PRCH2237=0 G ENSING
I PRCH2237'=0 G FAUXPR
S PRCH2237="ALL"
I $G(DUOUT)!$G(DTOUT) G EXIT
K DIR
ENECMS ;prompt for a unique eCMS contact. PRCHECMS equals ALL or selection from ACONTACT cross-reference.
S DIR("A")="Select a single eCMS Contact"
S DIR(0)="Y",DIR("B")="NO" D ^DIR
;If NO, set PRCHECMS="ALL". If YES lookup eCMS contact then return.
I Y=0 S (PRCHEML,PRCHECMS)="ALL"
I Y=1 D ECMS I PRCHECMS=0 G ENECMS
I $G(DUOUT)!$G(DTOUT) G EXIT
K DIR
DATE ;prompt for a date range.
;get default start and end dates
S PRCHDATE=$P($O(^PRCV(414.06,"AED","")),".")
S (PRCHSTDT,Y)=$P(PRCHDATE,".") D DD^%DT S PRCHSTAR=Y
D NOW^%DTC S (PRCHENDT,Y)=X D DD^%DT S PRCHEND=Y
K Y
S DIR("A")="Select ALL DATES: ("_PRCHSTAR_" - "_PRCHEND_")"
S DIR(0)="Y",DIR("B")="NO" D ^DIR
;If YES, set PRCHDATE="ALL" for "ALL DATES". If NO prompt for START and END dates.
I Y=1 S PRCHDATE="ALL"
I Y=0 D I PRCHSTDT=0 G DATE
.K DIR,Y
.; get start date
.S PRCHSTDT=0
.S DIR("A")=" Starting date: "
.S DIR(0)="DA^"_PRCHDATE_":NOW:EX",DIR("B")="TODAY" D ^DIR
.S:Y'="^" PRCHSTDT=Y
.Q:Y="^"
.; get end date
.K DIR,Y
.S PRCHENDT=0
.S DIR("A")=" Ending date: "
.S DIR(0)="DA^"_PRCHSTDT_":NOW:EX",DIR("B")="TODAY" D ^DIR
.S:Y'="^" PRCHENDT=Y
.S:Y="^" PRCHSTDT=0
.Q
I $G(DUOUT)!$G(DTOUT) G EXIT
K DIR
ENSTN ;prompt for a unique station or substation. PRCHSTN equals ALL or selection from ASN cross-reference.
;If user has access to only one station, set the variable to that station and skip the prompt.
; And if the station selected does not have substations be sure to skip asking for them.
S PRCSUBF=0
I PRCH411=1 S PRCHSTN=$O(PRCH411(0)) S PRCSUBF=1 D:+$G(PRCH411(PRCHSTN)) SUBSTN S:$G(PRCHSUB)="" PRCHSUB="ALL" G ENFCP
I (PRCHOPT=2)&(PRCHURSN=1) S PRCHSTN=$O(PRCHURSN(0)) D:+$G(PRCH411(PRCHSTN)) SUBSTN S:$G(PRCHSUB)="" PRCHSUB="ALL" G ENFCP
S DIR("A")="Select a single STATION NUMBER"
S DIR(0)="Y",DIR("B")="NO" D ^DIR
;If NO, set PRCHSTN="ALL". If YES lookup station contact then return.
I Y=0 S PRCHSTN="ALL",PRCHSUB="ALL"
I Y=1 D STN I PRCHSTN=0 G ENSTN
I $G(DUOUT)!$G(DTOUT) G EXIT
K DIR
ENFCP ;prompt for a unique Fund Control Point. PRCHFUND equals ALL or selection from ACP cross-reference.
;gather FCP accessable to this end-user
S DIR("A")="Select a single FUND CONTROL POINT"
S DIR(0)="Y",DIR("B")="NO" D ^DIR
;If NO, set PRCHFUND="ALL". If YES lookup control point.
I Y=0 S PRCHFUND="ALL"
I Y=1 D FCP I PRCHFUND=0 G ENFCP
I $G(DUOUT)!$G(DTOUT) G EXIT
K DIR
ENTYPE ;
S DIR(0)="LA^1:4",DIR("B")="1-4"
S DIR("?")="This response must be a list or range, e.g., 1,3 or 1-2,4."
S DIR("A",1)="TRANSACTION EVENTS:"
S DIR("A",2)=""
S DIR("A",3)=" 1 Sent to eCMS (includes resent 2237s)"
S DIR("A",4)=" 2 Returned to Accountable Officer"
S DIR("A",5)=" 3 Returned to Control Point"
S DIR("A",6)=" 4 Cancelled within eCMS"
S DIR("A",7)=""
S DIR("A")="Select one or more of the above events: "
D ^DIR
S PRCHTYPE=Y,PRCHTT=0,PRCHTYTX=""
F I=1:1 S PRCHTT=$P(PRCHTYPE,",",I) Q:PRCHTT="" S:PRCHTYTX'="" PRCHTYTX=PRCHTYTX_", " S PRCHTYTX=PRCHTYTX_$S(PRCHTT=1:"Sent to eCMS",PRCHTT=2:"Returned to AO",PRCHTT=3:"Returned to CP",PRCHTT=4:"Cancelled within eCMS",1:"")
I $G(DUOUT)!$G(DTOUT) G EXIT
K DIR
ENERROR ;prompt for inclusion of ERROR text. Default = NO, do not include error text.
S DIR("A")="Display event ERROR TEXT"
S DIR(0)="Y",DIR("B")="NO" D ^DIR
;If NO, set PRCHERTX=0.
I Y=0 S PRCHERTX=0
I Y=1 S PRCHERTX=1
I $G(DUOUT)!$G(DTOUT) G EXIT
K DIR
; This is the end of the sort selection. Send to display/print.
D FAUXPR
Q
;
SINGLE ;
K DIC
S DIC=414.06,DIC(0)="AEQZ",D="B"
S DIC("A")="Select a 2237: "
S:PRCHOPT=2 DIC("S")="S PRCH=$P(^(0),U) I $D(PRCHURCP($S($P(PRCH,""-"",4)'="""":$P(PRCH,""-"",4),1:PRCH),+$G(PRCHURSN($P(PRCH,""-"")))))=1"
D IX^DIC
K DIC,PRCH,RESULTS
Q:Y=-1
S PRCH2237=Y(0,0),PRCHERTX=1
K DIR
Q
;
ECMS ;Returns with PRCHECMS set. Failure code = 0
S PRCHECMS=0
K DIR
W !
; Populate DIR(0) for a SET of CODES DIR call
S DIR("L",1)="Select one of the following eCMS Contacts:"
S DIR("L",2)=""
S DIR(0)="SO^",PRCRIL=2,PRCRI=0,PRCETMP0=""
F S PRCETMP0=$O(^PRCV(414.06,"AUNQEC",PRCETMP0)) Q:PRCETMP0="" D
. S PRCRI=PRCRI+1,PRCRIL=PRCRIL+1,PRCETMP1=$P(PRCETMP0," "),PRCETMP3=$P(PRCETMP0," ",2)
. S:PRCRI>1 DIR(0)=DIR(0)_";"
. S DIR(0)=DIR(0)_PRCRI_":"_PRCETMP1
. S:PRCRI<10 DIR("L",PRCRIL)=" "
. S DIR("L",PRCRIL)=$G(DIR("L",PRCRIL))_" "_PRCRI_" "_PRCETMP0
.Q
S DIR("L")=""
D ^DIR
Q:$G(DUOUT)!$G(DTOUT)!$D(DIRUT)
S PRCRIL=Y+2
S PRCHECMS=$P(DIR("L",PRCRIL),Y_" ",2)
S PRCHEML=$P(PRCHECMS," ",2)
K DIR,PRCRIL
Q
;
STN ;Returns with PRCHSTN set. Failure = 0
; EXCLUDE SUBSTATIONS from inital lookup.
S PRCHSTN=0
K DIR
S DIR(0)="PO^411:AEQ"
S DIR("A")="Select Station"
S DIR("S")="I (+$P(^(0),U)=$P(^(0),U))&($D(PRCHJSN($P(^(0),U)))=1)"
S:PRCHOPT=2 DIR("S")="I ($D(PRCHURSN(+($P(^(0),U))))=1)&(+$P(^(0),U)=$P(^(0),U))&($D(PRCHJSN($P(^(0),U)))=1)"
D ^DIR
K PRCRI ; Variable left over from DD; file 411 lookup post action code.
Q:$G(DUOUT)!$G(DTOUT)!$D(DIRUT)
S PRCHSTN=$P(Y,"^",2)
SUBSTN ;Returns PRCHSUB = ALL if the user does not want to select a substation.
S PRCHSUB=""
I +$G(PRCH411(PRCHSTN))=0 S PRCHSUB="ALL" Q
S DIR("A")=" Do you want to see the records for ALL the substations of "_PRCHSTN
S DIR(0)="Y",DIR("B")="YES" D ^DIR
I Y=1 S PRCHSUB="ALL" Q
I $G(DUOUT)!$G(DTOUT)!$D(DIRUT) G:'PRCSUBF STN Q
K DIR
S DIR(0)="SO^1:"_PRCHSTN_" "_PRCH411(PRCHSTN,PRCHSTN)
S PRCRI=1,PRCHSUB=PRCHSTN
F S PRCHSUB=$O(PRCH411(PRCHSTN,PRCHSUB)) Q:+PRCHSUB'>0 S:$D(PRCHJSB(PRCHSUB))=1 PRCRI=PRCRI+1,DIR(0)=DIR(0)_";"_PRCRI_":"_PRCHSUB_" "_PRCH411(PRCHSTN,PRCHSUB)
S DIR("A")="SUBSTATION" D ^DIR
;Returns PRCHSUB = "NONE" if user selects the PRIMARY station number,
; otherwise PRCHSUB is the substation number and PRCHSTN = "SUB".
I $G(DUOUT)!$G(DTOUT)!$D(DIRUT) G SUBSTN
S PRCHSUB=$P(Y(0)," ")
I PRCHSUB'=PRCHSTN S PRCHSTN="SUB" Q
S:PRCHSUB=PRCHSTN PRCHSUB="NONE"
Q
;
FCP ; Allow selection of a FCP.
; All FCP accessible to this user are stored in the following array which can be used for AO screening.
; PRCHURCP(fcp with any leading zeros,station)=full fcp text
S PRCHFUND=0
S DIC=414.06,DIC(0)="AEQSZ",D="AUNQFCP"
S DIC("A")="Fund Control Point: "
S DIC("W")=""
; No screen if AO and ALL stations
; Screens
; AO/Manager/Fiscal and a station
S:(PRCHOPT=1)&(+PRCHSTN'=0) DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1"
S:(PRCHOPT=1)&(PRCHSTN="SUB") DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1"
S:(PRCHOPT=3)&(+PRCHSTN'=0) DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1"
S:(PRCHOPT=3)&(PRCHSTN="SUB") DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1"
; CP and ALL stations
S:(PRCHOPT=2)&(PRCHSTN="ALL") DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X)))=10"
; CP and a station/substation
S:(PRCHOPT=2)&(+PRCHSTN'=0) DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1"
S:(PRCHOPT=2)&(PRCHSTN="SUB") DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1"
D IX^DIC
Q:Y=-1
S PRCHFUND=$P(Y(0,0),"-",4)
W " "_PRCHFUND
K DIC,D
Q
;
USERFCP ; Build the arrays of the FCPs and Stations the user has access to.
K PRCHURCP,PRCHURSN
; Build array for Stations and Substations that exist in 414.06
S PRCHI=0
F S PRCHI=$O(^PRCV(414.06,"ASN",PRCHI)) Q:+PRCHI'>0 S PRCHJSN(PRCHI)=""
S PRCHI=""
F S PRCHI=$O(^PRCV(414.06,"ASB",PRCHI)) Q:PRCHI="" S PRCHJSB(PRCHI)=""
S PRCHURLV="OTHER"
; Set PPM Accountable Officers and Managers to the same access level (PRCHURLV)
S:(PRCHEMP=2)!(PRCHEMP=4) PRCHURLV="AO"
S (PRCH420,PRCHURSN)=0
; Allow access to all FCP if using AO option AND file 200 SUPPLY EMPLOYEE access level is AO or Manager OR if entered on REPORT3.
I ((PRCHOPT=1)&(PRCHURLV="AO"))!(PRCHOPT=3) F S PRCH420=$O(^PRC(420,PRCH420)) Q:+PRCH420'>0 D
.S PRCH4206=0
.F S PRCH4206=$O(^PRC(420,PRCH420,1,PRCH4206)) Q:+PRCH4206'>0 D
..S PRCH6=$P($G(^PRC(420,PRCH420,1,PRCH4206,0)),"^")
..Q:PRCH6=""
..Q:$P($G(^PRC(420,PRCH420,1,PRCH4206,0)),"^",11)'="Y"
..S:'$D(PRCHURSN(PRCH420)) PRCHURSN(PRCH420)=PRCH420,PRCHURSN=PRCHURSN+1
..S PRCHURCP($P(PRCH6," "),PRCH420)=PRCH6
..Q
.Q
; If entring on REPORT2, check for individual's assigned FCP regardless of file 200 SUPPLY EMPLOYEE access level.
; This is also restriced within 420 to disallow REQUESTER acccess (only allow CP Clerk or CP Official)
I PRCHOPT=2 S PRCHURSN=0 F S PRCH420=$O(^PRC(420,PRCH420)) Q:+PRCH420'>0 D
.S PRCH4206=0
.F S PRCH4206=$O(^PRC(420,PRCH420,1,PRCH4206)) Q:+PRCH4206'>0 D
..S PRCH6=$P($G(^PRC(420,PRCH420,1,PRCH4206,0)),"^")
..Q:PRCH6=""
..Q:$P($G(^PRC(420,PRCH420,1,PRCH4206,0)),"^",11)'="Y"
..Q:'+$G(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0))
..Q:(+$P($G(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0)),"^",2)=3)!(+$P($G(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0)),"^",2)=0)
..S:'$D(PRCHURSN(PRCH420)) PRCHURSN(PRCH420)=PRCH420,PRCHURSN=PRCHURSN+1
..S PRCHURCP($P(PRCH6," "),PRCH420)=PRCH6
..Q
.Q
; Set count for IFCAP instance number of stations, and each station's number of substations.
;$D(^DIC(4,+$P(^(0),U,10),0)) S PRCHSITE=$P(^(0),U,1)
S (PRCH411,PRCHINSN)=0 F S PRCHINSN=$O(^PRC(411,"B",PRCHINSN)) Q:+PRCHINSN'>0 D
.S PRCHINIC=0 S PRCHINIC=$O(^PRC(411,"B",PRCHINSN,PRCHINIC)) Q:+PRCHINIC'>0 D
..I PRCHINIC<1000000 S PRCH411=PRCH411+1,PRCH411(+PRCHINSN,$P(^PRC(411,PRCHINIC,0),"^"))=$P(^DIC(4,$P(^PRC(411,PRCHINIC,0),"^",10),0),"^")
..I PRCHINIC>999999 S PRCH411(+PRCHINSN)=$G(PRCH411(+PRCHINSN))+1,PRCH411(+PRCHINSN,$P(^PRC(411,PRCHINIC,0),"^"))=$P(^DIC(4,$P(^PRC(411,PRCHINIC,0),"^",10),0),"^")
..Q
.Q
Q
;
EXITZT ;
W ! D ^%ZISC,HOME^%ZIS K IO("Q")
EXIT ;
K %ZIS,D,DIC,DIR,DIROUT,DIRUT,PRCH420,PRCH4206,PRCH6,PRCRI,PRCSUBF,X,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK
K PRCH2237,PRCHDATE,PRCHECMS,PRCHEMP,PRCHENDT,PRCHFUND,PRCHJSB,PRCHJSN,PRCHLAST,PRCHOPT,PRCHSTDT,PRCHSTN,PRCHSUB,PRCHTYPE,PRCHURCP,PRCHURSN,PRCHURLV
Q
;
FAUXPR ; DISPLAY OF THE SELECTIONS
;SINGLE 2237
I $G(PRCH2237)'="ALL" W !!,"The single 2237, "_PRCH2237_", has been selected for printing. " G FX
;EVERYTHING ELSE
W !!,"All eCMS 2237s matching your selections below will be displayed:"
;ECMS CONTACT
W !," ",$S(PRCHECMS="ALL":"All eCMS Contacts",1:"eCMS Contact: "_PRCHEML)
;DATE RANGE
I PRCHDATE'="ALL" S Y=PRCHSTDT D DD^%DT S PRCHSTAR=Y S Y=PRCHENDT D DD^%DT S PRCHEND=Y K Y
W !," ",$S(PRCHDATE="ALL":"All dates: ("_PRCHSTAR_" - "_PRCHEND_")",1:"Dates: ("_PRCHSTAR_" - "_PRCHEND_")")
;STATION/SUBSTATION
W !," ",$S(PRCHSTN="ALL":"All Stations and Substations",1:"Station: "_$S(+PRCHSTN:PRCHSTN,PRCHSTN="SUB":+PRCHSUB,1:""))
W $S($G(PRCHSUB)="NONE":", records for substation "_+PRCHSTN,((+PRCHSTN)&($D(PRCH411(+PRCHSTN))'=11)):"",((+PRCHSTN)&(PRCHSUB="ALL")):", records for each substation",((PRCHSTN="ALL")&(PRCHSUB="ALL")):"",1:", records for substation "_PRCHSUB)
;FCP
W !," ",$S(PRCHFUND="ALL":"All Fund Control Points",1:"Fund Control Point: "_PRCHFUND)
;EVENT TYPE
W !," Event Types selected are:"
S PRCHI=1,PRCHSLTY=PRCHTYPE
S PRCHTYPE=","
F S PRCHJ=$P(PRCHSLTY,",",PRCHI) Q:+PRCHJ'>0 S PRCHI=PRCHI+1 D
.I PRCHJ=1 W !," 1 = Sent to eCMS (includes resent 2237s)" S PRCHTYPE=PRCHTYPE_"1,"
.I PRCHJ=2 W !," 2 = Returned to Accountable Officer" S PRCHTYPE=PRCHTYPE_"6,"
.I PRCHJ=3 W !," 3 = Returned to Control Point" S PRCHTYPE=PRCHTYPE_"8,"
.I PRCHJ=4 W !," 4 = Cancelled within eCMS" S PRCHTYPE=PRCHTYPE_"10,"
.Q
;FULL ERROR TEXT
W !," ",$S(PRCHERTX:"The full text of any errors will be displayed.",1:"A note will display for any errors, but not the full text.")
FX ; Get Device
K IOP,%ZIS
W ! S %ZIS="MQ" D ^%ZIS W !
G:POP EXIT
I $D(IO("Q")) S ZTRTN="GATHER^PRCHJRP6",ZTDESC="Transaction Report - eCMS/IFCAP",ZTSAVE("PRCH*")="" D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!"),! G EXITZT
D GATHER^PRCHJRP6
D EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHJRP5 13280 printed Sep 23, 2025@19:44:16 Page 2
PRCHJRP5 ;OI&T/DDA - Transaction Report from 414.06 ;3/22/13 13:48
+1 ;;5.1;IFCAP;**174**;Oct 20,2000;Build 23
+2 ;Per VHA Directive 2004-38, this routine should not be modified.
+3 ;
+4 QUIT
EN ;Revised Transaction Report
+1 ;setup user data
+2 KILL XQORNOD
DO OP^XQCHK
+3 SET PRCHOPT=$SELECT($PIECE(XQOPT,"^")="PRCHJ TRANS REPORT":1,$PIECE(XQOPT,"^")="PRCHJ TRANS REPORT2":2,$PIECE(XQOPT,"^")="PRCHJ TRANS REPORT3":3,1:0)
+4 IF PRCHOPT=0
WRITE !!,"REPORT MUST BE RUN FROM APPROPRIATE MENU OPTIONS."
QUIT
+5 if $GET(PRCHEMP)=""
SET PRCHEMP=$$GET1^DIQ(200,DUZ_",",400,"I")
+6 IF PRCHOPT=1
IF '((PRCHEMP=2)!(PRCHEMP=4))
WRITE !!,"You are not a PPM Accountable Officer or Manager!"
QUIT
EN2 ;
+1 DO USERFCP
+2 IF PRCHURSN=0
WRITE !!,"You do not have access to any Fund Control Points!"
QUIT
ENSING ;prompt for a single 2237
+1 KILL DIR
+2 SET PRCH2237=0
+3 SET DIR("A")="Select a single 2237 TRANSACTION NUMBER"
+4 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+5 ;If YES go to lookup and display for a single 2237.
+6 IF Y=1
KILL DIR
DO SINGLE
IF PRCH2237=0
GOTO ENSING
+7 IF PRCH2237'=0
GOTO FAUXPR
+8 SET PRCH2237="ALL"
+9 IF $GET(DUOUT)!$GET(DTOUT)
GOTO EXIT
+10 KILL DIR
ENECMS ;prompt for a unique eCMS contact. PRCHECMS equals ALL or selection from ACONTACT cross-reference.
+1 SET DIR("A")="Select a single eCMS Contact"
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+3 ;If NO, set PRCHECMS="ALL". If YES lookup eCMS contact then return.
+4 IF Y=0
SET (PRCHEML,PRCHECMS)="ALL"
+5 IF Y=1
DO ECMS
IF PRCHECMS=0
GOTO ENECMS
+6 IF $GET(DUOUT)!$GET(DTOUT)
GOTO EXIT
+7 KILL DIR
DATE ;prompt for a date range.
+1 ;get default start and end dates
+2 SET PRCHDATE=$PIECE($ORDER(^PRCV(414.06,"AED","")),".")
+3 SET (PRCHSTDT,Y)=$PIECE(PRCHDATE,".")
DO DD^%DT
SET PRCHSTAR=Y
+4 DO NOW^%DTC
SET (PRCHENDT,Y)=X
DO DD^%DT
SET PRCHEND=Y
+5 KILL Y
+6 SET DIR("A")="Select ALL DATES: ("_PRCHSTAR_" - "_PRCHEND_")"
+7 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+8 ;If YES, set PRCHDATE="ALL" for "ALL DATES". If NO prompt for START and END dates.
+9 IF Y=1
SET PRCHDATE="ALL"
+10 IF Y=0
Begin DoDot:1
+11 KILL DIR,Y
+12 ; get start date
+13 SET PRCHSTDT=0
+14 SET DIR("A")=" Starting date: "
+15 SET DIR(0)="DA^"_PRCHDATE_":NOW:EX"
SET DIR("B")="TODAY"
DO ^DIR
+16 if Y'="^"
SET PRCHSTDT=Y
+17 if Y="^"
QUIT
+18 ; get end date
+19 KILL DIR,Y
+20 SET PRCHENDT=0
+21 SET DIR("A")=" Ending date: "
+22 SET DIR(0)="DA^"_PRCHSTDT_":NOW:EX"
SET DIR("B")="TODAY"
DO ^DIR
+23 if Y'="^"
SET PRCHENDT=Y
+24 if Y="^"
SET PRCHSTDT=0
+25 QUIT
End DoDot:1
IF PRCHSTDT=0
GOTO DATE
+26 IF $GET(DUOUT)!$GET(DTOUT)
GOTO EXIT
+27 KILL DIR
ENSTN ;prompt for a unique station or substation. PRCHSTN equals ALL or selection from ASN cross-reference.
+1 ;If user has access to only one station, set the variable to that station and skip the prompt.
+2 ; And if the station selected does not have substations be sure to skip asking for them.
+3 SET PRCSUBF=0
+4 IF PRCH411=1
SET PRCHSTN=$ORDER(PRCH411(0))
SET PRCSUBF=1
if +$GET(PRCH411(PRCHSTN))
DO SUBSTN
if $GET(PRCHSUB)=""
SET PRCHSUB="ALL"
GOTO ENFCP
+5 IF (PRCHOPT=2)&(PRCHURSN=1)
SET PRCHSTN=$ORDER(PRCHURSN(0))
if +$GET(PRCH411(PRCHSTN))
DO SUBSTN
if $GET(PRCHSUB)=""
SET PRCHSUB="ALL"
GOTO ENFCP
+6 SET DIR("A")="Select a single STATION NUMBER"
+7 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+8 ;If NO, set PRCHSTN="ALL". If YES lookup station contact then return.
+9 IF Y=0
SET PRCHSTN="ALL"
SET PRCHSUB="ALL"
+10 IF Y=1
DO STN
IF PRCHSTN=0
GOTO ENSTN
+11 IF $GET(DUOUT)!$GET(DTOUT)
GOTO EXIT
+12 KILL DIR
ENFCP ;prompt for a unique Fund Control Point. PRCHFUND equals ALL or selection from ACP cross-reference.
+1 ;gather FCP accessable to this end-user
+2 SET DIR("A")="Select a single FUND CONTROL POINT"
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+4 ;If NO, set PRCHFUND="ALL". If YES lookup control point.
+5 IF Y=0
SET PRCHFUND="ALL"
+6 IF Y=1
DO FCP
IF PRCHFUND=0
GOTO ENFCP
+7 IF $GET(DUOUT)!$GET(DTOUT)
GOTO EXIT
+8 KILL DIR
ENTYPE ;
+1 SET DIR(0)="LA^1:4"
SET DIR("B")="1-4"
+2 SET DIR("?")="This response must be a list or range, e.g., 1,3 or 1-2,4."
+3 SET DIR("A",1)="TRANSACTION EVENTS:"
+4 SET DIR("A",2)=""
+5 SET DIR("A",3)=" 1 Sent to eCMS (includes resent 2237s)"
+6 SET DIR("A",4)=" 2 Returned to Accountable Officer"
+7 SET DIR("A",5)=" 3 Returned to Control Point"
+8 SET DIR("A",6)=" 4 Cancelled within eCMS"
+9 SET DIR("A",7)=""
+10 SET DIR("A")="Select one or more of the above events: "
+11 DO ^DIR
+12 SET PRCHTYPE=Y
SET PRCHTT=0
SET PRCHTYTX=""
+13 FOR I=1:1
SET PRCHTT=$PIECE(PRCHTYPE,",",I)
if PRCHTT=""
QUIT
if PRCHTYTX'=""
SET PRCHTYTX=PRCHTYTX_", "
SET PRCHTYTX=PRCHTYTX_$SELECT(PRCHTT=1:"Sent to eCMS",PRCHTT=2:"Returned to AO",PRCHTT=3:"Returned to CP",PRCHTT=4:"Cancelled within eCMS",1:"")
+14 IF $GET(DUOUT)!$GET(DTOUT)
GOTO EXIT
+15 KILL DIR
ENERROR ;prompt for inclusion of ERROR text. Default = NO, do not include error text.
+1 SET DIR("A")="Display event ERROR TEXT"
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+3 ;If NO, set PRCHERTX=0.
+4 IF Y=0
SET PRCHERTX=0
+5 IF Y=1
SET PRCHERTX=1
+6 IF $GET(DUOUT)!$GET(DTOUT)
GOTO EXIT
+7 KILL DIR
+8 ; This is the end of the sort selection. Send to display/print.
+9 DO FAUXPR
+10 QUIT
+11 ;
SINGLE ;
+1 KILL DIC
+2 SET DIC=414.06
SET DIC(0)="AEQZ"
SET D="B"
+3 SET DIC("A")="Select a 2237: "
+4 if PRCHOPT=2
SET DIC("S")="S PRCH=$P(^(0),U) I $D(PRCHURCP($S($P(PRCH,""-"",4)'="""":$P(PRCH,""-"",4),1:PRCH),+$G(PRCHURSN($P(PRCH,""-"")))))=1"
+5 DO IX^DIC
+6 KILL DIC,PRCH,RESULTS
+7 if Y=-1
QUIT
+8 SET PRCH2237=Y(0,0)
SET PRCHERTX=1
+9 KILL DIR
+10 QUIT
+11 ;
ECMS ;Returns with PRCHECMS set. Failure code = 0
+1 SET PRCHECMS=0
+2 KILL DIR
+3 WRITE !
+4 ; Populate DIR(0) for a SET of CODES DIR call
+5 SET DIR("L",1)="Select one of the following eCMS Contacts:"
+6 SET DIR("L",2)=""
+7 SET DIR(0)="SO^"
SET PRCRIL=2
SET PRCRI=0
SET PRCETMP0=""
+8 FOR
SET PRCETMP0=$ORDER(^PRCV(414.06,"AUNQEC",PRCETMP0))
if PRCETMP0=""
QUIT
Begin DoDot:1
+9 SET PRCRI=PRCRI+1
SET PRCRIL=PRCRIL+1
SET PRCETMP1=$PIECE(PRCETMP0," ")
SET PRCETMP3=$PIECE(PRCETMP0," ",2)
+10 if PRCRI>1
SET DIR(0)=DIR(0)_";"
+11 SET DIR(0)=DIR(0)_PRCRI_":"_PRCETMP1
+12 if PRCRI<10
SET DIR("L",PRCRIL)=" "
+13 SET DIR("L",PRCRIL)=$GET(DIR("L",PRCRIL))_" "_PRCRI_" "_PRCETMP0
+14 QUIT
End DoDot:1
+15 SET DIR("L")=""
+16 DO ^DIR
+17 if $GET(DUOUT)!$GET(DTOUT)!$DATA(DIRUT)
QUIT
+18 SET PRCRIL=Y+2
+19 SET PRCHECMS=$PIECE(DIR("L",PRCRIL),Y_" ",2)
+20 SET PRCHEML=$PIECE(PRCHECMS," ",2)
+21 KILL DIR,PRCRIL
+22 QUIT
+23 ;
STN ;Returns with PRCHSTN set. Failure = 0
+1 ; EXCLUDE SUBSTATIONS from inital lookup.
+2 SET PRCHSTN=0
+3 KILL DIR
+4 SET DIR(0)="PO^411:AEQ"
+5 SET DIR("A")="Select Station"
+6 SET DIR("S")="I (+$P(^(0),U)=$P(^(0),U))&($D(PRCHJSN($P(^(0),U)))=1)"
+7 if PRCHOPT=2
SET DIR("S")="I ($D(PRCHURSN(+($P(^(0),U))))=1)&(+$P(^(0),U)=$P(^(0),U))&($D(PRCHJSN($P(^(0),U)))=1)"
+8 DO ^DIR
+9 ; Variable left over from DD; file 411 lookup post action code.
KILL PRCRI
+10 if $GET(DUOUT)!$GET(DTOUT)!$DATA(DIRUT)
QUIT
+11 SET PRCHSTN=$PIECE(Y,"^",2)
SUBSTN ;Returns PRCHSUB = ALL if the user does not want to select a substation.
+1 SET PRCHSUB=""
+2 IF +$GET(PRCH411(PRCHSTN))=0
SET PRCHSUB="ALL"
QUIT
+3 SET DIR("A")=" Do you want to see the records for ALL the substations of "_PRCHSTN
+4 SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
+5 IF Y=1
SET PRCHSUB="ALL"
QUIT
+6 IF $GET(DUOUT)!$GET(DTOUT)!$DATA(DIRUT)
if 'PRCSUBF
GOTO STN
QUIT
+7 KILL DIR
+8 SET DIR(0)="SO^1:"_PRCHSTN_" "_PRCH411(PRCHSTN,PRCHSTN)
+9 SET PRCRI=1
SET PRCHSUB=PRCHSTN
+10 FOR
SET PRCHSUB=$ORDER(PRCH411(PRCHSTN,PRCHSUB))
if +PRCHSUB'>0
QUIT
if $DATA(PRCHJSB(PRCHSUB))=1
SET PRCRI=PRCRI+1
SET DIR(0)=DIR(0)_";"_PRCRI_":"_PRCHSUB_" "_PRCH411(PRCHSTN,PRCHSUB)
+11 SET DIR("A")="SUBSTATION"
DO ^DIR
+12 ;Returns PRCHSUB = "NONE" if user selects the PRIMARY station number,
+13 ; otherwise PRCHSUB is the substation number and PRCHSTN = "SUB".
+14 IF $GET(DUOUT)!$GET(DTOUT)!$DATA(DIRUT)
GOTO SUBSTN
+15 SET PRCHSUB=$PIECE(Y(0)," ")
+16 IF PRCHSUB'=PRCHSTN
SET PRCHSTN="SUB"
QUIT
+17 if PRCHSUB=PRCHSTN
SET PRCHSUB="NONE"
+18 QUIT
+19 ;
FCP ; Allow selection of a FCP.
+1 ; All FCP accessible to this user are stored in the following array which can be used for AO screening.
+2 ; PRCHURCP(fcp with any leading zeros,station)=full fcp text
+3 SET PRCHFUND=0
+4 SET DIC=414.06
SET DIC(0)="AEQSZ"
SET D="AUNQFCP"
+5 SET DIC("A")="Fund Control Point: "
+6 SET DIC("W")=""
+7 ; No screen if AO and ALL stations
+8 ; Screens
+9 ; AO/Manager/Fiscal and a station
+10 if (PRCHOPT=1)&(+PRCHSTN'=0)
SET DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1"
+11 if (PRCHOPT=1)&(PRCHSTN="SUB")
SET DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1"
+12 if (PRCHOPT=3)&(+PRCHSTN'=0)
SET DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1"
+13 if (PRCHOPT=3)&(PRCHSTN="SUB")
SET DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1"
+14 ; CP and ALL stations
+15 if (PRCHOPT=2)&(PRCHSTN="ALL")
SET DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X)))=10"
+16 ; CP and a station/substation
+17 if (PRCHOPT=2)&(+PRCHSTN'=0)
SET DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1"
+18 if (PRCHOPT=2)&(PRCHSTN="SUB")
SET DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1"
+19 DO IX^DIC
+20 if Y=-1
QUIT
+21 SET PRCHFUND=$PIECE(Y(0,0),"-",4)
+22 WRITE " "_PRCHFUND
+23 KILL DIC,D
+24 QUIT
+25 ;
USERFCP ; Build the arrays of the FCPs and Stations the user has access to.
+1 KILL PRCHURCP,PRCHURSN
+2 ; Build array for Stations and Substations that exist in 414.06
+3 SET PRCHI=0
+4 FOR
SET PRCHI=$ORDER(^PRCV(414.06,"ASN",PRCHI))
if +PRCHI'>0
QUIT
SET PRCHJSN(PRCHI)=""
+5 SET PRCHI=""
+6 FOR
SET PRCHI=$ORDER(^PRCV(414.06,"ASB",PRCHI))
if PRCHI=""
QUIT
SET PRCHJSB(PRCHI)=""
+7 SET PRCHURLV="OTHER"
+8 ; Set PPM Accountable Officers and Managers to the same access level (PRCHURLV)
+9 if (PRCHEMP=2)!(PRCHEMP=4)
SET PRCHURLV="AO"
+10 SET (PRCH420,PRCHURSN)=0
+11 ; Allow access to all FCP if using AO option AND file 200 SUPPLY EMPLOYEE access level is AO or Manager OR if entered on REPORT3.
+12 IF ((PRCHOPT=1)&(PRCHURLV="AO"))!(PRCHOPT=3)
FOR
SET PRCH420=$ORDER(^PRC(420,PRCH420))
if +PRCH420'>0
QUIT
Begin DoDot:1
+13 SET PRCH4206=0
+14 FOR
SET PRCH4206=$ORDER(^PRC(420,PRCH420,1,PRCH4206))
if +PRCH4206'>0
QUIT
Begin DoDot:2
+15 SET PRCH6=$PIECE($GET(^PRC(420,PRCH420,1,PRCH4206,0)),"^")
+16 if PRCH6=""
QUIT
+17 if $PIECE($GET(^PRC(420,PRCH420,1,PRCH4206,0)),"^",11)'="Y"
QUIT
+18 if '$DATA(PRCHURSN(PRCH420))
SET PRCHURSN(PRCH420)=PRCH420
SET PRCHURSN=PRCHURSN+1
+19 SET PRCHURCP($PIECE(PRCH6," "),PRCH420)=PRCH6
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 ; If entring on REPORT2, check for individual's assigned FCP regardless of file 200 SUPPLY EMPLOYEE access level.
+23 ; This is also restriced within 420 to disallow REQUESTER acccess (only allow CP Clerk or CP Official)
+24 IF PRCHOPT=2
SET PRCHURSN=0
FOR
SET PRCH420=$ORDER(^PRC(420,PRCH420))
if +PRCH420'>0
QUIT
Begin DoDot:1
+25 SET PRCH4206=0
+26 FOR
SET PRCH4206=$ORDER(^PRC(420,PRCH420,1,PRCH4206))
if +PRCH4206'>0
QUIT
Begin DoDot:2
+27 SET PRCH6=$PIECE($GET(^PRC(420,PRCH420,1,PRCH4206,0)),"^")
+28 if PRCH6=""
QUIT
+29 if $PIECE($GET(^PRC(420,PRCH420,1,PRCH4206,0)),"^",11)'="Y"
QUIT
+30 if '+$GET(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0))
QUIT
+31 if (+$PIECE($GET(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0)),"^",2)=3)!(+$PIECE($GET(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0)),"^",2)=0)
QUIT
+32 if '$DATA(PRCHURSN(PRCH420))
SET PRCHURSN(PRCH420)=PRCH420
SET PRCHURSN=PRCHURSN+1
+33 SET PRCHURCP($PIECE(PRCH6," "),PRCH420)=PRCH6
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 ; Set count for IFCAP instance number of stations, and each station's number of substations.
+37 ;$D(^DIC(4,+$P(^(0),U,10),0)) S PRCHSITE=$P(^(0),U,1)
+38 SET (PRCH411,PRCHINSN)=0
FOR
SET PRCHINSN=$ORDER(^PRC(411,"B",PRCHINSN))
if +PRCHINSN'>0
QUIT
Begin DoDot:1
+39 SET PRCHINIC=0
SET PRCHINIC=$ORDER(^PRC(411,"B",PRCHINSN,PRCHINIC))
if +PRCHINIC'>0
QUIT
Begin DoDot:2
+40 IF PRCHINIC<1000000
SET PRCH411=PRCH411+1
SET PRCH411(+PRCHINSN,$PIECE(^PRC(411,PRCHINIC,0),"^"))=$PIECE(^DIC(4,$PIECE(^PRC(411,PRCHINIC,0),"^",10),0),"^")
+41 IF PRCHINIC>999999
SET PRCH411(+PRCHINSN)=$GET(PRCH411(+PRCHINSN))+1
SET PRCH411(+PRCHINSN,$PIECE(^PRC(411,PRCHINIC,0),"^"))=$PIECE(^DIC(4,$PIECE(^PRC(411,PRCHINIC,0),"^",10),0),"^")
+42 QUIT
End DoDot:2
+43 QUIT
End DoDot:1
+44 QUIT
+45 ;
EXITZT ;
+1 WRITE !
DO ^%ZISC
DO HOME^%ZIS
KILL IO("Q")
EXIT ;
+1 KILL %ZIS,D,DIC,DIR,DIROUT,DIRUT,PRCH420,PRCH4206,PRCH6,PRCRI,PRCSUBF,X,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK
+2 KILL PRCH2237,PRCHDATE,PRCHECMS,PRCHEMP,PRCHENDT,PRCHFUND,PRCHJSB,PRCHJSN,PRCHLAST,PRCHOPT,PRCHSTDT,PRCHSTN,PRCHSUB,PRCHTYPE,PRCHURCP,PRCHURSN,PRCHURLV
+3 QUIT
+4 ;
FAUXPR ; DISPLAY OF THE SELECTIONS
+1 ;SINGLE 2237
+2 IF $GET(PRCH2237)'="ALL"
WRITE !!,"The single 2237, "_PRCH2237_", has been selected for printing. "
GOTO FX
+3 ;EVERYTHING ELSE
+4 WRITE !!,"All eCMS 2237s matching your selections below will be displayed:"
+5 ;ECMS CONTACT
+6 WRITE !," ",$SELECT(PRCHECMS="ALL":"All eCMS Contacts",1:"eCMS Contact: "_PRCHEML)
+7 ;DATE RANGE
+8 IF PRCHDATE'="ALL"
SET Y=PRCHSTDT
DO DD^%DT
SET PRCHSTAR=Y
SET Y=PRCHENDT
DO DD^%DT
SET PRCHEND=Y
KILL Y
+9 WRITE !," ",$SELECT(PRCHDATE="ALL":"All dates: ("_PRCHSTAR_" - "_PRCHEND_")",1:"Dates: ("_PRCHSTAR_" - "_PRCHEND_")")
+10 ;STATION/SUBSTATION
+11 WRITE !," ",$SELECT(PRCHSTN="ALL":"All Stations and Substations",1:"Station: "_$SELECT(+PRCHSTN:PRCHSTN,PRCHSTN="SUB":+PRCHSUB,1:""))
+12 WRITE $SELECT($GET(PRCHSUB)="NONE":", records for substation "_+PRCHSTN,((+PRCHSTN)&(...
... $DATA(PRCH411(+PRCHSTN))'=11)):"",((+PRCHSTN)&(PRCHSUB="ALL")):", records for each substation",((PRCHSTN="ALL")&(PRCHSUB="ALL")):"",1:", records for substation "_PRCHSUB)
+13 ;FCP
+14 WRITE !," ",$SELECT(PRCHFUND="ALL":"All Fund Control Points",1:"Fund Control Point: "_PRCHFUND)
+15 ;EVENT TYPE
+16 WRITE !," Event Types selected are:"
+17 SET PRCHI=1
SET PRCHSLTY=PRCHTYPE
+18 SET PRCHTYPE=","
+19 FOR
SET PRCHJ=$PIECE(PRCHSLTY,",",PRCHI)
if +PRCHJ'>0
QUIT
SET PRCHI=PRCHI+1
Begin DoDot:1
+20 IF PRCHJ=1
WRITE !," 1 = Sent to eCMS (includes resent 2237s)"
SET PRCHTYPE=PRCHTYPE_"1,"
+21 IF PRCHJ=2
WRITE !," 2 = Returned to Accountable Officer"
SET PRCHTYPE=PRCHTYPE_"6,"
+22 IF PRCHJ=3
WRITE !," 3 = Returned to Control Point"
SET PRCHTYPE=PRCHTYPE_"8,"
+23 IF PRCHJ=4
WRITE !," 4 = Cancelled within eCMS"
SET PRCHTYPE=PRCHTYPE_"10,"
+24 QUIT
End DoDot:1
+25 ;FULL ERROR TEXT
+26 WRITE !," ",$SELECT(PRCHERTX:"The full text of any errors will be displayed.",1:"A note will display for any errors, but not the full text.")
FX ; Get Device
+1 KILL IOP,%ZIS
+2 WRITE !
SET %ZIS="MQ"
DO ^%ZIS
WRITE !
+3 if POP
GOTO EXIT
+4 IF $DATA(IO("Q"))
SET ZTRTN="GATHER^PRCHJRP6"
SET ZTDESC="Transaction Report - eCMS/IFCAP"
SET ZTSAVE("PRCH*")=""
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Cancelled!"),!
GOTO EXITZT
+5 DO GATHER^PRCHJRP6
+6 DO EXIT
+7 QUIT
