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

RTDPA1.m

Go to the documentation of this file.
  1. RTDPA1 ;TROY ISC/MJK,PKE-Record Label Creation ; 4/2/03 10:01am
  1. ;;2.0;Record Tracking;**25,31,35**;10/22/91
  1. I '$D(RTAPL) D APL2^RTPSET D NEXT:$D(RTAPL) K RTAPL,RTSYS Q
  1. ;
  1. NEXT S RTA=+RTAPL D ASK^RTB K RTA G Q:$D(RTESC),NEXT:Y<0 S RTE=X
  1. S RTDC("S")="I $P(^(0),U,4)=+RTAPL,$S('$D(RTTY):1,$P(^RT(+Y,0),U,3)=+RTTY:1,1:0)",RTSEL="S",RTSEL("A")="Select Label" D ^RTUTL2 K RTSEL
  1. I $D(RTY) S RTION=$S('$D(RTFR):"",1:$P(RTFR,"^",4)) F RTI=0:0 S RTI=$O(RTY(RTI)) Q:'RTI S RT=+RTY(RTI) D REC^RTL1
  1. I $D(RTY) D Q G NEXT
  1. D ASK I '$D(RTESC) D Q G NEXT
  1. Q K RT,RTI,RTY,RTC,RT1,RTBCIFN,RTDC,RTE,RTESC,RTION
  1. K RTRANEW,%YV,DIC1,DIY,DIYS,N,POP
  1. K Y,Y2,X,X1,DIE,DIC,DA Q
  1. ASK S RTESC="",RTRD(1)="Yes^create a new record or volume",RTRD(2)="No^do not create any new records",RTRD("B")=2,RTRD(0)="S",RTRD("A")="Do you wish to create a new record or volume? " D SET^RTRD K RTRD I $E(X)="^" S RTESC="" Q
  1. I $E(X)="Y" S RTSHOW="" D TYPE1:$D(RTTY),TYPE:'$D(RTTY) K RTSHOW
  1. Q
  1. ;
  1. TYPE K RTESC W ! S DIC="^DIC(195.2,",DIC("S")="I $P(^(0),U,3)=+RTAPL,$S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)",DIC("A")="Select NEW Record Type: ",DIC(0)="IAEMQ" D ^DIC K DIC S:X="^" RTESC="" Q:Y<0 D TYPE1^RTUTL S RTKILL=""
  1. TYPE1 D CREATE S RTTY1=+RTTY F RTTY2=0:0 S RTTY2=$O(^DIC(195.2,RTTY1,"LINKED","B",RTTY2)) Q:'RTTY2 I $D(^DIC(195.2,RTTY2,0)),'$D(^RT("AT",RTTY2,RTE)) S Y=RTTY2 D TYPE1^RTUTL,CREATE
  1. S Y=RTTY1 K RTTY,RTTY1,RTTY2 D:'$D(RTKILL) TYPE1^RTUTL K RTKILL Q
  1. ;
  1. CREATE ;Entry pt. with RTAPL, RTE and RTTY set
  1. F I=0:0 S I=$O(^RT("AA",+RTAPL,RTE,I)) Q:'I I $D(^RT(I,0)),+$P(^(0),"^",3)=+RTTY Q
  1. I I Q:$D(RTBKGRD)
  1. I I W !!?3,*7,$P(RTAPL,"^",9)," already has a '",$P(^DIC(195.2,+RTTY,0),"^"),"' record (#",I,") Vol: ",+$P(^RT(I,0),"^",7),"." I $P(^DIC(195.2,+RTTY,0),"^",17)'="y" W !?3,"[Multiple volumes are NOT allowed for this record type.]" Q
  1. I I D NEW^RTT1 Q
  1. S RTVOL=1,RTPAR="" D SET K RTVOL,RTPAR Q
  1. ;
  1. SET ;Entry pt. with RTAPL, RTE, RTTY, RTVOL, and RTPAR defined; RTDIV optional
  1. S X=$S($D(RTDIV):+RTDIV,1:"") I 'X S X=+$O(^DIC(195.1,+RTAPL,"INST",0)),X=$S('$O(^(X)):X,1:"")
  1. S RTINIT="" I $D(^DIC(195.1,"AB",+RTTY,+RTAPL,+X)),$D(^DIC(195.1,+RTAPL,"INST",+X,"TYPE",+$O(^(+X,0)),0)) S RTINIT=^(0)
  1. D NOW^%DTC S RTNOW=%,I=$P(^RT(0),"^",3) K %
  1. ;D:$D(XRTL) T0^%ZOSV ; monitor record creation et, non-inter = 'rtshow
  1. I '$D(RTSHOW),$D(XRTL) D T0^%ZOSV
  1. LOCK S I=I+1 S:$L(I)=4 I=10000 L +^RT(I):1 I '$T!$D(^RT(I)) L -^RT(I) G LOCK
  1. S ^RT(I,0)=RTE_"^"_+^DIC(195.4,1,"SITE"),^RT("B",RTE,I)="",^(0)=$P(^RT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)'[0:DUZ,1:0),"^RT(")=I S:$P(RTE,";",2)="DPT(" ^RT(I,0)=^RT(I,0)_"^^^^^^^"_+RTE,^RT("C",+RTE,I)="" L -^RT(I)
  1. ;
  1. S (RT,DA)=I,DIE="^RT(",DR="[RT NEW RECORD]"
  1. D ^DIE K DQ,DE,RTINIT,RTNOW D MOVE^RTUTL1
  1. ;S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; end et, non-inter
  1. I '$D(RTSHOW),$D(XRT0) S XRTN=$T(+0) D T1^%ZOSV
  1. W:'$D(RTBKGRD) !?3,"...'",$E($P(^DIC(195.2,+RTTY,0),"^"),1,22),?30," VOL: ",RTVOL,"' created (#",RT,")"
  1. ;
  1. MOR I '$D(RTSHOW),'$D(RTADM) Q
  1. N RTERROR
  1. MOR1 S X=$S($D(RTFR):$P(RTFR,"^",4),1:""),RTERROR=0
  1. I $S(X']"":1,'$D(^%ZIS(1,"B",X)):1,'$D(^%ZIS(1,+$O(^(X,0)),0)):1,1:0) D Q:POP I RTERROR G MOR1
  1. . S %ZIS("A")="Select Barcode Printer: ",%ZIS="QN" D ^%ZIS K %ZIS,IO("Q") Q:POP
  1. . S X=ION
  1. . S RTA=$O(^%ZIS(1,"B",ION,0)) I ^%ZIS(1,RTA,"TYPE")="VTRM" D ER^RTL1 S RTERROR=1
  1. S RTION=X D REC^RTL1 K RTION Q
  1. Q
  1. TRAN ;creat record transfered in
  1. S RTRANEW="",RTA=+RTAPL D ASK^RTB K RTA G Q:$D(RTESC),TRAN:Y<0 S RTE=X
  1. D ASK I '$D(RTESC) D Q G TRAN