- 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 Jan 18, 2025@03:35 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