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