PRCSAPP2 ;WISC/KMB/BGJ/SC/ASU - CONTINUATION OF PRCSAPP ; 3/31/05 3:07pm
V ;;5.1;IFCAP;**14,81,148,186**;Oct 20, 2000;Build 10
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*81-if a 2237 trx is being approved & it originated from
;DynaMed RIL then update DM re. approval thru a call to rtn PRCVTAP
;
;PRC*5.1*186 Fix duplicate entries in file 443 by changing
; the direct field 1.5 and x-ref 'AC' set to
; Fileman update of status field.
;
FINAL ; ask if request was reviewed. print request if needed.
;
N PRCSDA,PRCPRIB,RPRINT,REPLY,REPLY1 S (REPLY,REPLY1)=2
; SKIPRNT is set in PRCSEB - official can approve request here
; immediately after creating it in PRCSEB
I '$D(SKIPRNT) S %=0 W !,"Requests need to be reviewed prior to approval.",!,"Have you reviewed this request" D YN^DICN Q:%=-1 I %=0 W !,"Enter yes or no.",! H 1 G FINAL
I '$D(SKIPRNT),%=2 S (PRCS,PRCPRIB)=DA,TRNODE(0)=0 D:PRCHQ=1 NODE^PRCS58OB(DA,.TRNODE) S RPRINT=$S(PRCHQ=1:"^PRCE58P0",PRCHQ=5:"DQ^PRCPRIB0",1:"^PRCSD12") D @RPRINT S DA=PRCS
;ask for approval, signature
N PRCOKCB S PRCOKCB=$$OKCCBOC^PRCSCK($P(PRCSN,"^"))
I PRCOKCB S %=1 W !,"Is this request ready for approval" D YN^DICN W:%=0 !,"Enter yes or no.",! G:%=0 FINAL Q:%=-1 S REPLY=%
I 'PRCOKCB S REPLY=2
; PRC*5.1*148 start
; if Approver is a requestor, violation to segregation of duties
I REPLY=1,PRCHQ=1,$P($G(^PRCS(410,DA,7)),"^",1)=DUZ D G FINAL2
. W !!,"You are the CP Clerk (Requestor) on this 1358 transaction."
. W " Per Segregation",!,"of Duties, the CP Clerk (Requestor)"
. W " is not permitted to Approve the 1358." H 2
; PRC*5.1*148 end
;
FINAL1 ;*******************************************************************
;PRCVDM -flag helps in determining if ans is Y to transmit to Fiscal
;then ONLY pass the data to DynaMed for DM related approved 2237
;*******************************************************************
N PRCVDM
I REPLY=1 W !,"Is this request ready for transmission to A&MM/Fiscal" S %=2 D YN^DICN Q:%=-1 S REPLY1=% S:%=1 PRCVDM=1 I %=0 W !,"Enter yes or no.",! H 1 G FINAL1
; if ready for approval (or reviewed), store on cross-ref F,F1
FINAL2 ;
D:REPLY=2 W5^PRCSEB D:REPLY=1 W51^PRCSEB Q:REPLY1=2
I $D(SKIPRNT) S MESSAGE="" D ESIG^PRCUESIG(DUZ,.MESSAGE) Q:MESSAGE'=1
;********************************************************************
;all of the line item data that we need to pass to DM on a DM related
;trx. is recorded in the file 410 at this point for an approved 2237
;********************************************************************
I $D(PRCVDM),PRCVDM=1 D EN^PRCVTAP(DA)
;
; set record in 443, clean up 410, change cp uncommitted balance
; using TRANS^PRCSES, in 420
D NOW^%DTC S PRCS=%
S PRCSCP=$S($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$P(^(0),U,12),1:"")
N PPMFLG S:$D(PPMFLG1) PPMFLG=10
L +^PRCS(410,DA):15 Q:$T=0
S $P(^PRCS(410,DA,10),U,4)=$S(PRCSCP=1!(PRCHQ=1):$O(^PRCD(442.3,"C",10,0)),1:$O(^PRCD(442.3,"C",60,0))),$P(^(11),U,3)=""
N ESTSHIP,COST S ESTSHIP=$P($G(^PRCS(410,DA,9)),"^",4),COST=$P($G(^PRCS(410,DA,4)),"^",8)
N IJ F IJ=1,8 S $P(^PRCS(410,DA,4),"^",IJ)=ESTSHIP+COST
K ^PRCS(410,"F",+PRCSN_"-"_+PRC("CP")_"-"_$P($P(PRCSN,U),"-",5),DA),^PRCS(410,"F1",$P($P(PRCSN,U),"-",5)_"-"_+PRCSN_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)=""
D ERS410^PRC0G(DA_"^A")
;
S MESSAGE=""
D ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
K MESSAGE
S X=PRCST D TRANS^PRCSES
;
S PRCSSCP=0 F PRCSSI=1:1 S PRCSSCP=$O(^PRCS(410,DA,12,PRCSSCP)) Q:PRCSSCP'>0 I $D(^PRCS(410,DA,12,PRCSSCP,0)) S X=$P(^(0),U,2) I X S DA(1)=DA,DA=PRCSSCP D TRANS^PRCSEZZ S DA=DA(1)
K PRCSSCP,PRCSSI L -^PRCS(410,DA)
;PRC*5.1*186
I $P(PRCSN,U,4)>1 D
. S X=$P(PRCSN,U,1),DIC="^PRC(443,",DIC(0)="L",DLAYGO=443 D ^DIC K DIC,DLAYGO,X
. S X=$O(^PRCD(442.3,"C",60,0)) S:PRCSCP=1 X=$O(^PRCD(442.3,"C",10,0))
. S PRCSSTS=X
. S DIE="^PRC(443,",DR="1.5////^S X=PRCSSTS" D ^DIE K DR,DIE,PRCSSTS
. S $P(^PRC(443,DA,0),U,11)=$P(PRCSN,U,6)
D EN2^PRCPWI
S (PRCS,PRCPRIB)=DA,TRNODE(0)=0 D:PRCHQ=1 NODE^PRCS58OB(DA,.TRNODE)
TAG ;
S PRCSDA=DA
S D0=DA,PRCHQ=$S(PRCHQ=1:"QUE^PRCE58P2",PRCHQ=5:"DQ^PRCPRIB0",1:"QUE^PRCSP12"),PRCHQ("DEST")=$S(PRCSCP=1!(PRCHQ="QUE^PRCE58P2"):"F",1:"S") D ^PRCHQUE S DA=PRCSDA Q
Q
PRT ;
K IO("Q") S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S D0=$G(DA),ZTRTN=$S(PRCHQ=1:"QUE^PRCE58P2",PRCHQ=5:"DQ^PRCPRIB0",1:"^PRCSP12"),ZTSAVE("PRNTALL")="",ZTSAVE("DA")="",ZTSAVE("D0")="",ZTSAVE("PRC*")="",ZTSAVE("TRNODE*")="" D ^%ZTLOAD,^%ZISC Q
I IO=IO(0) U IO D:PRCHQ=5 DQ^PRCPRIB0 D:PRCHQ=1 ^PRCE58P0 D:PRCHQ'=1&(PRCHQ'=5) ^PRCSD12 D ^%ZISC W:$Y>0 @IOF Q
U IO D:PRCHQ=5 DQ^PRCPRIB0 D:PRCHQ=1 QUE^PRCE58P2 D:PRCHQ'=1&(PRCHQ'=5) ^PRCSP12 D ^%ZISC W:$Y>0 @IOF
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSAPP2 4876 printed Apr 09, 2024@21:03:52 Page 2
PRCSAPP2 ;WISC/KMB/BGJ/SC/ASU - CONTINUATION OF PRCSAPP ; 3/31/05 3:07pm
V ;;5.1;IFCAP;**14,81,148,186**;Oct 20, 2000;Build 10
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*81-if a 2237 trx is being approved & it originated from
+4 ;DynaMed RIL then update DM re. approval thru a call to rtn PRCVTAP
+5 ;
+6 ;PRC*5.1*186 Fix duplicate entries in file 443 by changing
+7 ; the direct field 1.5 and x-ref 'AC' set to
+8 ; Fileman update of status field.
+9 ;
FINAL ; ask if request was reviewed. print request if needed.
+1 ;
+2 NEW PRCSDA,PRCPRIB,RPRINT,REPLY,REPLY1
SET (REPLY,REPLY1)=2
+3 ; SKIPRNT is set in PRCSEB - official can approve request here
+4 ; immediately after creating it in PRCSEB
+5 IF '$DATA(SKIPRNT)
SET %=0
WRITE !,"Requests need to be reviewed prior to approval.",!,"Have you reviewed this request"
DO YN^DICN
if %=-1
QUIT
IF %=0
WRITE !,"Enter yes or no.",!
HANG 1
GOTO FINAL
+6 IF '$DATA(SKIPRNT)
IF %=2
SET (PRCS,PRCPRIB)=DA
SET TRNODE(0)=0
if PRCHQ=1
DO NODE^PRCS58OB(DA,.TRNODE)
SET RPRINT=$SELECT(PRCHQ=1:"^PRCE58P0",PRCHQ=5:"DQ^PRCPRIB0",1:"^PRCSD12")
DO @RPRINT
SET DA=PRCS
+7 ;ask for approval, signature
+8 NEW PRCOKCB
SET PRCOKCB=$$OKCCBOC^PRCSCK($PIECE(PRCSN,"^"))
+9 IF PRCOKCB
SET %=1
WRITE !,"Is this request ready for approval"
DO YN^DICN
if %=0
WRITE !,"Enter yes or no.",!
if %=0
GOTO FINAL
if %=-1
QUIT
SET REPLY=%
+10 IF 'PRCOKCB
SET REPLY=2
+11 ; PRC*5.1*148 start
+12 ; if Approver is a requestor, violation to segregation of duties
+13 IF REPLY=1
IF PRCHQ=1
IF $PIECE($GET(^PRCS(410,DA,7)),"^",1)=DUZ
Begin DoDot:1
+14 WRITE !!,"You are the CP Clerk (Requestor) on this 1358 transaction."
+15 WRITE " Per Segregation",!,"of Duties, the CP Clerk (Requestor)"
+16 WRITE " is not permitted to Approve the 1358."
HANG 2
End DoDot:1
GOTO FINAL2
+17 ; PRC*5.1*148 end
+18 ;
FINAL1 ;*******************************************************************
+1 ;PRCVDM -flag helps in determining if ans is Y to transmit to Fiscal
+2 ;then ONLY pass the data to DynaMed for DM related approved 2237
+3 ;*******************************************************************
+4 NEW PRCVDM
+5 IF REPLY=1
WRITE !,"Is this request ready for transmission to A&MM/Fiscal"
SET %=2
DO YN^DICN
if %=-1
QUIT
SET REPLY1=%
if %=1
SET PRCVDM=1
IF %=0
WRITE !,"Enter yes or no.",!
HANG 1
GOTO FINAL1
+6 ; if ready for approval (or reviewed), store on cross-ref F,F1
FINAL2 ;
+1 if REPLY=2
DO W5^PRCSEB
if REPLY=1
DO W51^PRCSEB
if REPLY1=2
QUIT
+2 IF $DATA(SKIPRNT)
SET MESSAGE=""
DO ESIG^PRCUESIG(DUZ,.MESSAGE)
if MESSAGE'=1
QUIT
+3 ;********************************************************************
+4 ;all of the line item data that we need to pass to DM on a DM related
+5 ;trx. is recorded in the file 410 at this point for an approved 2237
+6 ;********************************************************************
+7 IF $DATA(PRCVDM)
IF PRCVDM=1
DO EN^PRCVTAP(DA)
+8 ;
+9 ; set record in 443, clean up 410, change cp uncommitted balance
+10 ; using TRANS^PRCSES, in 420
+11 DO NOW^%DTC
SET PRCS=%
+12 SET PRCSCP=$SELECT($DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$PIECE(^(0),U,12),1:"")
+13 NEW PPMFLG
if $DATA(PPMFLG1)
SET PPMFLG=10
+14 LOCK +^PRCS(410,DA):15
if $TEST=0
QUIT
+15 SET $PIECE(^PRCS(410,DA,10),U,4)=$SELECT(PRCSCP=1!(PRCHQ=1):$ORDER(^PRCD(442.3,"C",10,0)),1:$ORDER(^PRCD(442.3,"C",60,0)))
SET $PIECE(^(11),U,3)=""
+16 NEW ESTSHIP,COST
SET ESTSHIP=$PIECE($GET(^PRCS(410,DA,9)),"^",4)
SET COST=$PIECE($GET(^PRCS(410,DA,4)),"^",8)
+17 NEW IJ
FOR IJ=1,8
SET $PIECE(^PRCS(410,DA,4),"^",IJ)=ESTSHIP+COST
+18 KILL ^PRCS(410,"F",+PRCSN_"-"_+PRC("CP")_"-"_$PIECE($PIECE(PRCSN,U),"-",5),DA),^PRCS(410,"F1",$PIECE($PIECE(PRCSN,U),"-",5)_"-"_+PRCSN_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
+19 if '$DATA(^PRCS(410,DA,11))
SET ^(11)=""
SET $PIECE(^(11),U,3)=""
+20 DO ERS410^PRC0G(DA_"^A")
+21 ;
+22 SET MESSAGE=""
+23 DO ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
+24 KILL MESSAGE
+25 SET X=PRCST
DO TRANS^PRCSES
+26 ;
+27 SET PRCSSCP=0
FOR PRCSSI=1:1
SET PRCSSCP=$ORDER(^PRCS(410,DA,12,PRCSSCP))
if PRCSSCP'>0
QUIT
IF $DATA(^PRCS(410,DA,12,PRCSSCP,0))
SET X=$PIECE(^(0),U,2)
IF X
SET DA(1)=DA
SET DA=PRCSSCP
DO TRANS^PRCSEZZ
SET DA=DA(1)
+28 KILL PRCSSCP,PRCSSI
LOCK -^PRCS(410,DA)
+29 ;PRC*5.1*186
+30 IF $PIECE(PRCSN,U,4)>1
Begin DoDot:1
+31 SET X=$PIECE(PRCSN,U,1)
SET DIC="^PRC(443,"
SET DIC(0)="L"
SET DLAYGO=443
DO ^DIC
KILL DIC,DLAYGO,X
+32 SET X=$ORDER(^PRCD(442.3,"C",60,0))
if PRCSCP=1
SET X=$ORDER(^PRCD(442.3,"C",10,0))
+33 SET PRCSSTS=X
+34 SET DIE="^PRC(443,"
SET DR="1.5////^S X=PRCSSTS"
DO ^DIE
KILL DR,DIE,PRCSSTS
+35 SET $PIECE(^PRC(443,DA,0),U,11)=$PIECE(PRCSN,U,6)
End DoDot:1
+36 DO EN2^PRCPWI
+37 SET (PRCS,PRCPRIB)=DA
SET TRNODE(0)=0
if PRCHQ=1
DO NODE^PRCS58OB(DA,.TRNODE)
TAG ;
+1 SET PRCSDA=DA
+2 SET D0=DA
SET PRCHQ=$SELECT(PRCHQ=1:"QUE^PRCE58P2",PRCHQ=5:"DQ^PRCPRIB0",1:"QUE^PRCSP12")
SET PRCHQ("DEST")=$SELECT(PRCSCP=1!(PRCHQ="QUE^PRCE58P2"):"F",1:"S")
DO ^PRCHQUE
SET DA=PRCSDA
QUIT
+3 QUIT
PRT ;
+1 KILL IO("Q")
SET %ZIS("B")="HOME"
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+2 IF $DATA(IO("Q"))
SET D0=$GET(DA)
SET ZTRTN=$SELECT(PRCHQ=1:"QUE^PRCE58P2",PRCHQ=5:"DQ^PRCPRIB0",1:"^PRCSP12")
SET ZTSAVE("PRNTALL")=""
SET ZTSAVE("DA")=""
SET ZTSAVE("D0")=""
SET ZTSAVE("PRC*")=""
SET ZTSAVE("TRNODE*")=""
DO ^%ZTLOAD
DO ^%ZISC
QUIT
+3 IF IO=IO(0)
USE IO
if PRCHQ=5
DO DQ^PRCPRIB0
if PRCHQ=1
DO ^PRCE58P0
if PRCHQ'=1&(PRCHQ'=5)
DO ^PRCSD12
DO ^%ZISC
if $Y>0
WRITE @IOF
QUIT
+4 USE IO
if PRCHQ=5
DO DQ^PRCPRIB0
if PRCHQ=1
DO QUE^PRCE58P2
if PRCHQ'=1&(PRCHQ'=5)
DO ^PRCSP12
DO ^%ZISC
if $Y>0
WRITE @IOF
+5 QUIT
