PRCFPR.m

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 ---PRCFPR   1410     printed  Apr 09, 2024@21:21:29                                                                                                                                                                                                      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       ;