PRCFPR ;WISC/LDB-FISCAL REPORTS ; 3/5/96 11:39 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Called from PRCHQUE to save (stack) Fiscal documents in file 421.8
;Input variables- PRCHXXDO (DO for print),PRDCHXXD1 (D1 for prints)
;PRCHREPR,PRCHFPT,PRC("SITE"),X(PRINTER)
N DA,DIC,DIE,DR,X,Y
Q:'$D(PRCHQ)!'$D(PRCHXXD0) S TYPE=$S($D(PRCHFPT):2,PRCHQ["^PRCE58P2":3,PRCHQ["^PRCSP12":4,1:1)
; quit if purchase card order has been printed
Q:$P($G(^PRC(442,PRCHXXD0,0)),"^",2)=25
S DIC="^PRC(421.8,",DLAYGO=421.8,DIC(0)="L",X=""""_D0_"""" D ^DIC K DLAYGO G:Y<0 EXIT K DIC
S DA=+Y,DIE="^PRC(421.8," K DIC D NOW^%DTC S DATE=$E(%,1,12)
S DR="1////^S X=TYPE;2////^S X=$TR(PRCHQ,""^"",""*"");5////^S X=DATE;6////^S X=$P($S($D(^PRC(442,PRCHXXD0,0))&(TYPE'=3):^(0),$D(^PRCS(410,PRCHXXD0,0))&((TYPE=3)!(TYPE=4)):^(0),1:""""),U);7////^S X=IOP"
S DR=DR_";9////^S X=$S($D(PRC(""SITE"")):PRC(""SITE""),1:$O(^PRC(411,0)))"
D ^DIE
K IOP
S:$D(PRCHXXD0) D0=PRCHXXD0 S:$D(PRCHXXD1) D1=PRCHXXD1
N DLAYGO S DA(1)=DA,DIC="^PRC(421.8,DA,1,",DLAYGO=421.8,DIC(0)="L",^PRC(421.8,DA,1,0)="^421.84^^" F PRCVAR="PRCHXXD0","PRCHXXD1","PRCHFPT","PRCHQ(""DEST"")","DEST","PRC(""SITE"")","PRCHREPR","D0","D1","DUZ" D
.I $D(@PRCVAR) S X=PRCVAR K DD,D0 D FILE^DICN S $P(^PRC(421.8,DA(1),1,+Y,0),U,2)=@PRCVAR
EXIT K %,DATE,DD,D0,PRCHQ,PRCVAR,TYPE Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFPR 1410 printed Nov 22, 2024@17:14:21 Page 2
PRCFPR ;WISC/LDB-FISCAL REPORTS ; 3/5/96 11:39 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Called from PRCHQUE to save (stack) Fiscal documents in file 421.8
+1 ;Input variables- PRCHXXDO (DO for print),PRDCHXXD1 (D1 for prints)
+2 ;PRCHREPR,PRCHFPT,PRC("SITE"),X(PRINTER)
+3 NEW DA,DIC,DIE,DR,X,Y
+4 if '$DATA(PRCHQ)!'$DATA(PRCHXXD0)
QUIT
SET TYPE=$SELECT($DATA(PRCHFPT):2,PRCHQ["^PRCE58P2":3,PRCHQ["^PRCSP12":4,1:1)
+5 ; quit if purchase card order has been printed
+6 if $PIECE($GET(^PRC(442,PRCHXXD0,0)),"^",2)=25
QUIT
+7 SET DIC="^PRC(421.8,"
SET DLAYGO=421.8
SET DIC(0)="L"
SET X=""""_D0_""""
DO ^DIC
KILL DLAYGO
if Y<0
GOTO EXIT
KILL DIC
+8 SET DA=+Y
SET DIE="^PRC(421.8,"
KILL DIC
DO NOW^%DTC
SET DATE=$EXTRACT(%,1,12)
+9 SET DR="1////^S X=TYPE;2////^S X=$TR(PRCHQ,""^"",""*"");5////^S X=DATE;6////^S X=$P($S($D(^PRC(442,PRCHXXD0,0))&(TYPE'=3):^(0),$D(^PRCS(410,PRCHXXD0,0))&((TYPE=3)!(TYPE=4)):^(0),1:""""),U);7////^S X=IOP"
+10 SET DR=DR_";9////^S X=$S($D(PRC(""SITE"")):PRC(""SITE""),1:$O(^PRC(411,0)))"
+11 DO ^DIE
+12 KILL IOP
+13 if $DATA(PRCHXXD0)
SET D0=PRCHXXD0
if $DATA(PRCHXXD1)
SET D1=PRCHXXD1
+14 NEW DLAYGO
SET DA(1)=DA
SET DIC="^PRC(421.8,DA,1,"
SET DLAYGO=421.8
SET DIC(0)="L"
SET ^PRC(421.8,DA,1,0)="^421.84^^"
FOR PRCVAR="PRCHXXD0","PRCHXXD1","PRCHFPT","PRCHQ(""DEST"")","DEST","PRC(""SITE"")","PRCHREPR","D0","D1","DUZ"
Begin DoDot:1
+15 IF $DATA(@PRCVAR)
SET X=PRCVAR
KILL DD,D0
DO FILE^DICN
SET $PIECE(^PRC(421.8,DA(1),1,+Y,0),U,2)=@PRCVAR
End DoDot:1
EXIT KILL %,DATE,DD,D0,PRCHQ,PRCVAR,TYPE
QUIT
+1 ;
+2 ;
