RTQ3 ;MJK/TROY ISC - ADT Link ;4/18/2017 10:45 AM ;
;;2.0;Record Tracking;**47**;10/22/91 ;Build 12
ADM I $D(RTAPL) D SAVE^RTPSET1,NEXT,RESTORE^RTPSET1 Q
NEXT Q:'$D(^DIC(195.4,1,"MAS")) S Y=+^("MAS") D APL1^RTPSET S IOP="" D ^%ZIS K IOP S Y=0
I $D(^RTV(195.9,"ADEV",ION)),$D(^RTV(195.9,+$O(^(ION,0)),0)),$D(^SC(+$P(^(0),U,2),0)),$P(^(0),"^",3)="Z",$D(^DIC(40.9,+$P(^(0),"^",22),0)),$P(^(0),"^",2)="AA" S Y=+$P(^RTV(195.9,+$O(^RTV(195.9,"ADEV",ION,0)),0),U,2)
I '$D(^SC(Y,0)) W ! S DIC("S")="I $P(^(0),U,3)=""Z"",$D(^DIC(40.9,+$P(^(0),U,22),0)),$P(^(0),U,2)=""AA""" S DIC("A")="Select Admitting Area: ",DIC(0)="IAEMQ",DIC="^SC(" D ^DIC K DIC G Q:Y<0
I Y S SDSC=+Y D NOW^%DTC S SDTTM=%,SDPL=0 D NEW:$P(DGFC,"^",2),ASK,QUE^RTQ2:$E(X)="Y"
Q K SDSC,SDTTM,SDPL,RTAPL Q
;
ASK S RTRD(1)="YES^request records",RTRD(2)="NO^indicate no records to be requested",RTRD("A")="ISSUE REQUEST FOR RECORDS? ",RTRD(0)="S",RTRD("B")=2 D SET^RTRD K RTRD Q
;
NEW S RTRD(1)="YES^print barcode labels",RTRD(2)="NO^do not print barcode labels",RTRD("B")=1,RTRD("A")="PRINT BARCODE LABELS FOR PATIENT'S FOLDERS? ",RTRD(0)="S" D SET^RTRD K RTRD Q:$E(X)'="Y"
;
NOASK S RTADM="",RTE=DFN_";DPT(",RTA=+RTAPL,RTB=SDSC_";SC(",Y=+$O(^RTV(195.9,"ABOR",RTB,RTA,0)) D SET^RTDPA3:'Y S RTB=Y,RTFR=Y_"^"_$P(^RTV(195.9,Y,0),"^",2,99) S:$P(RTSYS,"^",4)="e" $P(RTFR,"^",4,6)="^^"
S X="A" D SAVE S X=Y,A=RTA D INST1^RTUTL G NOASKQ:'$D(RTINST) S RTDIV=RTINST K RTINST
F RTBLD=0:0 S RTBLD=$O(^RTV(195.9,RTB,"RECS",RTBLD)) Q:'RTBLD I $D(^(RTBLD,0)) S X=^(0) I $D(^DIC(195.2,+X,0)),$P(X,"^",2)]"",$P(X,"^",2)'="n" S RTTY=+X,RTAPL=+$P(X,"^",3) I '$D(^RT("AT",RTTY,RTE)) D TYPE1^RTDPA1
NOASKQ S X="A" D RESTORE K RTSYS,RTDIV,RTA,RTB,RTFR,RTE,RTADM,RTBLD,RTTY,RTAPL Q
;
SAVE K RTMASAVE X "I $D("_X_")#2 S RTMASAVE=@X" I @("$D("_X_")>9") S %X=X_"(",%Y="RTMASAVE(" D %XY^%RCR
Q
;
RESTORE S:$D(RTMASAVE)#2 @X=RTMASAVE I $D(RTMASAVE)>9 S %X="RTMASAVE(",%Y=X_"(" D %XY^%RCR
K RTMASAVE Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTQ3 1969 printed Oct 16, 2024@18:35:13 Page 2
RTQ3 ;MJK/TROY ISC - ADT Link ;4/18/2017 10:45 AM ;
+1 ;;2.0;Record Tracking;**47**;10/22/91 ;Build 12
ADM IF $DATA(RTAPL)
DO SAVE^RTPSET1
DO NEXT
DO RESTORE^RTPSET1
QUIT
NEXT if '$DATA(^DIC(195.4,1,"MAS"))
QUIT
SET Y=+^("MAS")
DO APL1^RTPSET
SET IOP=""
DO ^%ZIS
KILL IOP
SET Y=0
+1 IF $DATA(^RTV(195.9,"ADEV",ION))
IF $DATA(^RTV(195.9,+$ORDER(^(ION,0)),0))
IF $DATA(^SC(+$PIECE(^(0),U,2),0))
IF $PIECE(^(0),"^",3)="Z"
IF $DATA(^DIC(40.9,+$PIECE(^(0),"^",22),0))
IF $PIECE(^(0),"^",2)="AA"
SET Y=+$PIECE(^RTV(195.9,+$ORDER(^RTV(195.9,"ADEV",ION,0)),0),U,2)
+2 IF '$DATA(^SC(Y,0))
WRITE !
SET DIC("S")="I $P(^(0),U,3)=""Z"",$D(^DIC(40.9,+$P(^(0),U,22),0)),$P(^(0),U,2)=""AA"""
SET DIC("A")="Select Admitting Area: "
SET DIC(0)="IAEMQ"
SET DIC="^SC("
DO ^DIC
KILL DIC
if Y<0
GOTO Q
+3 IF Y
SET SDSC=+Y
DO NOW^%DTC
SET SDTTM=%
SET SDPL=0
if $PIECE(DGFC,"^",2)
DO NEW
DO ASK
if $EXTRACT(X)="Y"
DO QUE^RTQ2
Q KILL SDSC,SDTTM,SDPL,RTAPL
QUIT
+1 ;
ASK SET RTRD(1)="YES^request records"
SET RTRD(2)="NO^indicate no records to be requested"
SET RTRD("A")="ISSUE REQUEST FOR RECORDS? "
SET RTRD(0)="S"
SET RTRD("B")=2
DO SET^RTRD
KILL RTRD
QUIT
+1 ;
NEW SET RTRD(1)="YES^print barcode labels"
SET RTRD(2)="NO^do not print barcode labels"
SET RTRD("B")=1
SET RTRD("A")="PRINT BARCODE LABELS FOR PATIENT'S FOLDERS? "
SET RTRD(0)="S"
DO SET^RTRD
KILL RTRD
if $EXTRACT(X)'="Y"
QUIT
+1 ;
NOASK SET RTADM=""
SET RTE=DFN_";DPT("
SET RTA=+RTAPL
SET RTB=SDSC_";SC("
SET Y=+$ORDER(^RTV(195.9,"ABOR",RTB,RTA,0))
if 'Y
DO SET^RTDPA3
SET RTB=Y
SET RTFR=Y_"^"_$PIECE(^RTV(195.9,Y,0),"^",2,99)
if $PIECE(RTSYS,"^",4)="e"
SET $PIECE(RTFR,"^",4,6)="^^"
+1 SET X="A"
DO SAVE
SET X=Y
SET A=RTA
DO INST1^RTUTL
if '$DATA(RTINST)
GOTO NOASKQ
SET RTDIV=RTINST
KILL RTINST
+2 FOR RTBLD=0:0
SET RTBLD=$ORDER(^RTV(195.9,RTB,"RECS",RTBLD))
if 'RTBLD
QUIT
IF $DATA(^(RTBLD,0))
SET X=^(0)
IF $DATA(^DIC(195.2,+X,0))
IF $PIECE(X,"^",2)]""
IF $PIECE(X,"^",2)'="n"
SET RTTY=+X
SET RTAPL=+$PIECE(X,"^",3)
IF '$DATA(^RT("AT",RTTY,RTE))
DO TYPE1^RTDPA1
NOASKQ SET X="A"
DO RESTORE
KILL RTSYS,RTDIV,RTA,RTB,RTFR,RTE,RTADM,RTBLD,RTTY,RTAPL
QUIT
+1 ;
SAVE KILL RTMASAVE
XECUTE "I $D("_X_")#2 S RTMASAVE=@X"
IF @("$D("_X_")>9")
SET %X=X_"("
SET %Y="RTMASAVE("
DO %XY^%RCR
+1 QUIT
+2 ;
RESTORE if $DATA(RTMASAVE)#2
SET @X=RTMASAVE
IF $DATA(RTMASAVE)>9
SET %X="RTMASAVE("
SET %Y=X_"("
DO %XY^%RCR
+1 KILL RTMASAVE
QUIT
