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

PSDRPGS1.m

Go to the documentation of this file.
  1. PSDRPGS1 ;BIR/JPW-Reprint Green Sheet (VA FORM 10-2638) cont'd ; 3 Mar 98
  1. ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
  1. ;**Y2K compliance** display 4 digit year on va forms
  1. START ;loop through transactions
  1. ;second call to %ZIS to restore varibles for open execute
  1. I $D(ZTQUEUED) S IOP=ION D ^%ZIS U IO
  1. S PSD=$P(PSDS,"^",2),PSDCNT=1
  1. S PSD1="" F S PSD1=$O(PSD1(PSD1)) Q:PSD1="" D LOOP
  1. END K %ZIS,ANS,ASK,C,CNT,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,LINE,LOT,NAOU,NAOUN,NODE,NODE1
  1. K OK,ORD,ORDN,POP,PRT,PSD,PSD1,PSDA,PSDBY,PSDBYN,PSDCNT,PSDDT,PSDEV,PSDOUT,PSDCPI,PSDPN,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDTR,PSDTRN,PSDYR,REPRINT,QTY,SITE,STAT,TRANS,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
  1. D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. LOOP S PSDPN=$P(PSD1(PSD1),",",PSDCNT),PSDCNT=PSDCNT+1 I PSDPN="" S PSDCNT=1 Q
  1. S PSDA=$O(^PSD(58.81,"D",PSDPN,0)) D SET
  1. G LOOP
  1. Q
  1. SET ;set data for printing
  1. K TRANS,PSDTR S PSDOUT=0
  1. Q:'$D(^PSD(58.81,+PSDA,0)) S NODE=^PSD(58.81,+PSDA,0)
  1. Q:+$P(NODE,"^",3)'=+PSDS I (+$P(NODE,"^",11)>4)&(+$P(NODE,"^",11)'=10)&(+$P(NODE,U,11)'=13) Q
  1. I +$P($G(^PSD(58.81,PSDA,"CS")),"^",4) S REPRINT=1
  1. S PSD=+$P(NODE,"^",18)
  1. S NAOUN=$S($P($G(^PSD(58.8,+PSD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1. S PSDR=$P(NODE,"^",5),PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1. S PSDT=$P(NODE,"^",4)
  1. S QTY=$P(NODE,"^",6) I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3)
  1. S LOT=$P(NODE,"^",14),EXP=$P(NODE,"^",15),EXPD="" I EXP S Y=$E(EXP,1,7) X ^DD("DD") S EXPD=Y
  1. S (PSDBY,PSDBYN,ORD,ORDN)=""
  1. I $D(^PSD(58.81,PSDA,1)) S NODE1=^(1),PSDBY=$P(NODE1,"^"),ORD=$P(NODE1,"^",7)
  1. S:ORD ORDN=$S($P($G(^VA(200,ORD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1. S:PSDBY PSDBYN=$S($P($G(^VA(200,PSDBY,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1. S CNT=1,PSDTR(CNT)=+$O(^PSD(58.81,"AE",PSDA,0)) D:PSDTR(CNT) G:PSDOUT PRINT
  1. .S TRANS=1
  1. .D SETT Q:PSDOUT
  1. .S NAOU=+$P($G(^PSD(58.81,PSDTR(CNT),0)),"^",18)
  1. .S:NAOU $P(PSDTR(CNT),"^",2)=$S($P($G(^PSD(58.8,+NAOU,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1. PRINT ;print green sheet
  1. I ORDN]"",ORDN'="UNKNOWN" S ORDN=$P(ORDN,",")_","_$E($P(ORDN,",",2))
  1. I PSDBYN]"",PSDBYN'="UNKNOWN" S PSDBYN=$P(PSDBYN,",")_","_$E($P(PSDBYN,",",2))
  1. S PSDDT="" I PSDT S Y=PSDT X ^DD("DD")
  1. S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) S PSDDT=$E(PSDT,4,5)_"/"_$E(PSDT,6,7)_"/"_PSDYR
  1. W:$Y @IOF W:$D(REPRINT) ?10,"** REPRINT **" I '$D(TRANS) W ?33,NAOUN
  1. W:$D(TRANS) "** Transferred to: ",$S($P(PSDTR(CNT),"^",2)]"":$P(PSDTR(CNT),"^",2),1:$P(PSDTR(CNT-1),"^",2))," **"
  1. D A7BAR^PSDPGS1 I $D(A7PRT) W @A7BAR1,PSDPN,@A7BAR0 ;DALISC/JRR
  1. W !!,?56,PSDPN,!!,?6,PSDRN,?36,EXPD,?65,QTY,!!,?6,LOT,?20,ORDN,?42,PSDBYN,?60,$E(NAOUN,1,6),?67,PSDDT,!
  1. F LINE=1:1:50 W !
  1. W:ASK !
  1. W ?6,PSDRN,?61,PSDPN,!
  1. K DA,DIE,DR S DA=PSDA,DIE=58.81,DR="103////1" D ^DIE K DA,DIE,DR
  1. Q
  1. SETT ;set trans naous
  1. S PSDTRN=+$O(^PSD(58.81,"AE",+PSDTR(CNT),0)) Q:'PSDTRN
  1. S NAOU=$P($G(^PSD(58.81,+PSDTRN,0)),"^",18) I 'NAOU S PSDOUT=1 Q
  1. S:NAOU $P(PSDTR(CNT),"^",2)=$S($P($G(^PSD(58.8,+NAOU,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
  1. I $O(^PSD(58.81,"AE",+PSDTRN,0)) S CNT=CNT+1,PSDTR(CNT)=$O(^PSD(58.81,"AE",+PSDTRN,0)) G SETT
  1. Q