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