- RTSM3 ;MJK,PKE/TROY ISC;Site Manager's Menu(cont); ; 5/18/87 10:20 AM ;
- ;;v 2.0;Record Tracking;**14**;10/22/91
- 9 ;;Initialize Records
- D BOTH^RTSM Q:'$D(RADPT)
- W !!?5,"This option will use the patients in the",$S(RADPT:" RADIOLOGY",1:"")," PATIENT file"
- W !?5,"as a base to create the necessary ",$S(RADPT:"film jacket",1:"folder")," entries in the"
- W !?5,"RECORDS file. <This option does not print barcode labels.>"
- ;
- NUM S Y=$S($D(^TMP("RTDFNSTART",+RTAPL)):+^(+RTAPL),1:1) W !!,"Start at DFN: ",Y,"// " R X:DTIME S:X="" X=Y W:X["?" !!,"Enter a number." G NUM:X["?",Q9:'$T!('X)!(X'?.N) S ^(+RTAPL)=X
- K RTERM,RTION,^TMP($J) S RTLOAD="LOAD^RTSM3",RTMES1=$S('RADPT:"MAS Patient Folder",1:"Radiology Film Jacket Entry")_" Creation:" G LOAD^RTSM1
- Q9 K RADPT
- K X,%I,D Q
- ;
- 10 ;;Patient Record Labels
- S RTLOAD="PAT^RTSM3"
- ASK D BOTH^RTSM G Q10:'$D(RADPT) S RTMES1=$S(RTLOAD["PAT":"P",1:"Inp")_"atient '"_$S(RADPT:"Film Jacket",1:"MAS Folder")_"' Label Creation:"
- K RTLDIV
- S RTRD(4)="Ldivision, Name^,for Last Registration, sort by name of patient"
- S RTRD(3)="Division, Digits^,for Last Registration, sort by Terminal digits"
- S RTRD(1)="Name^sort labels by name of patient"
- S RTRD(2)="Terminal Digits^sort by last 2 numbers of SSN",RTRD("B")=2,RTRD("A")="Sort sequence for labels? ",RTRD(0)="S" D SET^RTRD K RTRD S (X,RTXX)=$E(X) I X'="N",X'="T",X'="D",X'="L" G Q10
- G ASK1:RTLOAD["IN"!(X="N")!(X="L")
- ;I '$D(^UTILITY("RTDPTSORT","START")) W !!,*7,"The ^UTILITY(""RTDPTSORT"") global does NOT exist." D CHKQ^RTSM4 G Q10
- ;I $D(^UTILITY("RTDPTSORT","START")),'$D(^("FINISH")) S S=+$P(^("START"),"^",2) W !!,*7,"The ^UTILITY(""RTDPTSORT"") global is currently being compiled." D CHK^RTSM4 G Q10
- ;
- I $D(^RTV(194.3,1,0)),($E($P(^(0),"^",3),1,3))'=($E(DT,1,3)) DO Q
- .W !!,*7,"The RECORD TRACKING SORT GLOBAL file(#194.3) "
- .I '$P(^(0),"^",2),'$P(^(0),"^",3) W "needs to be compiled"
- .;naked ref rtv(194.3,1,0)
- .E I '$P(^(0),"^",3) W "is currently being compiled" D Q10 Q
- .E W "needs additional compiling"
- .D CHKQ^RTSM4,Q10
- ;
- ASK1 K RTERM I "TD"[RTXX D TERM^RTSM2 G Q10:'$D(RTERM) I RTXX="D" K RTLDIV D ^RTLDIV G Q10:'$D(RTLDIV)
- I RTXX="L" K RTLDIV D NAM^RTLDIV G Q10:'$D(RTLDIV)
- S:'$D(RTERM) RTERM="NAME" D PRT G LOAD^RTSM1:$D(RTION)
- Q10 K RADPT,RTLOAD,RTMES1,RTERM
- K RTCXX,RTLDIV,X,J,DUOUT,RTXX,RTSTART Q
- ;
- LOAD S DFN=$S($D(^TMP("RTDFNSTART",+RTAPL)):^(+RTAPL)-1,1:0)
- F DFN=DFN:0 S DFN=$O(^DPT(DFN)) Q:'DFN I $D(^DPT(DFN,0)),$S('RADPT:1,$D(^RADPT(DFN,0)):1,1:0) S RTE=DFN_";DPT(" D RTTY^RTSM1 S ^TMP("RTDFNSTART",+RTAPL)=DFN
- K DFN Q
- ;
- PAT ;Patient Label Creation
- I RTERM'="NAME" D PAT0 I 1
- E D PAT1
- K RTRM0,RTRM1,DFN,RTNME,RTNME0,RTRM,RTTD,DFN Q
- ;
- PAT0 F RTRM0=1:1 S RTRM=$P(RTERM,"^",RTRM0) Q:RTRM="" DO
- .S RTTD=$S($D(RTSTART):RTSTART,1:RTRM_"0000000") K RTSTART
- .S RTRM1=0
- .FOR S RTTD=$O(^RTV(194.3,1,1,"AC",RTTD)) Q:$E(RTTD,1,2)'=RTRM!(RTTD="") DO
- . .S DFN=0
- . .F S DFN=$O(^RTV(194.3,1,1,"AC",RTTD,DFN)) Q:'DFN S X=^(DFN) D LB
- Q
- PAT1 S RTNME="" F RTNME0=0:0 S RTNME=$O(^DPT("B",RTNME)) Q:RTNME="" F DFN=0:0 S DFN=$O(^DPT("B",RTNME,DFN)) Q:'DFN D:'$D(RTLDIV) LBL I $D(RTLDIV) S X=$O(^DPT(DFN,"DIS",0)) S X=$S('X:"",'$D(^(X,0)):"",X:$P(^(0),"^",4),1:"") D LB
- Q
- LB I $D(RTLDIV) S RTLDV="^"_X_"^" I RTLDIV'[RTLDV K X,RTLDV Q
- ;
- ;
- LBL I $D(^DPT(DFN,0)),$S('$D(^(.35)):1,'^(.35):1,1:0),$S('RADPT:1,$D(^RADPT(DFN,0)):1,1:0) S RTE=DFN_";DPT(" D RTTY^RTSM1 K RTE Q
- Q
- ;
- 11 ;;Inpatient Labels
- S RTLOAD="IN^RTSM3" G ASK
- ;
- IN ;Inpatient Label
- S RTWARD="" F RTWARD1=0:0 S RTWARD=$O(^DPT("CN",RTWARD)) Q:RTWARD="" F DFN=0:0 S DFN=$O(^DPT("CN",RTWARD,DFN)) Q:'DFN D DFN:$S('RADPT:1,$D(^RADPT(DFN,0)):1,1:0)
- W !!,"Printing Labels..." S RTSORT=""
- F RTSORT1=0:0 S RTSORT=$O(^TMP($J,"RTSORT",RTSORT)) Q:RTSORT="" F DFN=0:0 S DFN=$O(^TMP($J,"RTSORT",RTSORT,DFN)) Q:'DFN S RTE=DFN_";DPT(" D RTTY^RTSM1:$D(^DPT(DFN,.1))
- K RTWARD,RTWARD1,DFN,RTE,RTSORT,RTSORT1
- K RTXX,X1 Q
- DFN Q:'$D(^DPT(DFN,0)) S X=^(0) I RTERM'="NAME" S X=$P(^(0),"^",9) I X S:$D(RTERM($E(X,8,9))) ^TMP($J,"RTSORT",$E(X,8,9)_$E(X,6,7)_$E(X,1,5),DFN)="" Q
- I X S ^TMP($J,"RTSORT",$P(X,"^"),DFN)="" Q
- Q
- ;add check for barcode field, screen for virtual term?
- PRT K RTION S DIC(0)="IAEMQ",DIC="^%ZIS(1,",DIC("A")="Select Label Printer: ",DIC("S")="I $D(^(""SUBTYPE"")),$D(^%ZIS(2,+^(""SUBTYPE""),0)),$E(^(0))=""P""" D ^DIC K DIC Q:Y<0 S RTION=$P(Y,"^",2)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTSM3 4449 printed Mar 13, 2025@21:39:51 Page 2
- RTSM3 ;MJK,PKE/TROY ISC;Site Manager's Menu(cont); ; 5/18/87 10:20 AM ;
- +1 ;;v 2.0;Record Tracking;**14**;10/22/91
- 9 ;;Initialize Records
- +1 DO BOTH^RTSM
- if '$DATA(RADPT)
- QUIT
- +2 WRITE !!?5,"This option will use the patients in the",$SELECT(RADPT:" RADIOLOGY",1:"")," PATIENT file"
- +3 WRITE !?5,"as a base to create the necessary ",$SELECT(RADPT:"film jacket",1:"folder")," entries in the"
- +4 WRITE !?5,"RECORDS file. <This option does not print barcode labels.>"
- +5 ;
- NUM SET Y=$SELECT($DATA(^TMP("RTDFNSTART",+RTAPL)):+^(+RTAPL),1:1)
- WRITE !!,"Start at DFN: ",Y,"// "
- READ X:DTIME
- if X=""
- SET X=Y
- if X["?"
- WRITE !!,"Enter a number."
- if X["?"
- GOTO NUM
- if '$TEST!('X)!(X'?.N)
- GOTO Q9
- SET ^(+RTAPL)=X
- +1 KILL RTERM,RTION,^TMP($JOB)
- SET RTLOAD="LOAD^RTSM3"
- SET RTMES1=$SELECT('RADPT:"MAS Patient Folder",1:"Radiology Film Jacket Entry")_" Creation:"
- GOTO LOAD^RTSM1
- Q9 KILL RADPT
- +1 KILL X,%I,D
- QUIT
- +2 ;
- 10 ;;Patient Record Labels
- +1 SET RTLOAD="PAT^RTSM3"
- ASK DO BOTH^RTSM
- if '$DATA(RADPT)
- GOTO Q10
- SET RTMES1=$SELECT(RTLOAD["PAT":"P",1:"Inp")_"atient '"_$SELECT(RADPT:"Film Jacket",1:"MAS Folder")_"' Label Creation:"
- +1 KILL RTLDIV
- +2 SET RTRD(4)="Ldivision, Name^,for Last Registration, sort by name of patient"
- +3 SET RTRD(3)="Division, Digits^,for Last Registration, sort by Terminal digits"
- +4 SET RTRD(1)="Name^sort labels by name of patient"
- +5 SET RTRD(2)="Terminal Digits^sort by last 2 numbers of SSN"
- SET RTRD("B")=2
- SET RTRD("A")="Sort sequence for labels? "
- SET RTRD(0)="S"
- DO SET^RTRD
- KILL RTRD
- SET (X,RTXX)=$EXTRACT(X)
- IF X'="N"
- IF X'="T"
- IF X'="D"
- IF X'="L"
- GOTO Q10
- +6 if RTLOAD["IN"!(X="N")!(X="L")
- GOTO ASK1
- +7 ;I '$D(^UTILITY("RTDPTSORT","START")) W !!,*7,"The ^UTILITY(""RTDPTSORT"") global does NOT exist." D CHKQ^RTSM4 G Q10
- +8 ;I $D(^UTILITY("RTDPTSORT","START")),'$D(^("FINISH")) S S=+$P(^("START"),"^",2) W !!,*7,"The ^UTILITY(""RTDPTSORT"") global is currently being compiled." D CHK^RTSM4 G Q10
- +9 ;
- +10 IF $DATA(^RTV(194.3,1,0))
- IF ($EXTRACT($PIECE(^(0),"^",3),1,3))'=($EXTRACT(DT,1,3))
- Begin DoDot:1
- +11 WRITE !!,*7,"The RECORD TRACKING SORT GLOBAL file(#194.3) "
- +12 IF '$PIECE(^(0),"^",2)
- IF '$PIECE(^(0),"^",3)
- WRITE "needs to be compiled"
- +13 ;naked ref rtv(194.3,1,0)
- +14 IF '$TEST
- IF '$PIECE(^(0),"^",3)
- WRITE "is currently being compiled"
- DO Q10
- QUIT
- +15 IF '$TEST
- WRITE "needs additional compiling"
- +16 DO CHKQ^RTSM4
- DO Q10
- End DoDot:1
- QUIT
- +17 ;
- ASK1 KILL RTERM
- IF "TD"[RTXX
- DO TERM^RTSM2
- if '$DATA(RTERM)
- GOTO Q10
- IF RTXX="D"
- KILL RTLDIV
- DO ^RTLDIV
- if '$DATA(RTLDIV)
- GOTO Q10
- +1 IF RTXX="L"
- KILL RTLDIV
- DO NAM^RTLDIV
- if '$DATA(RTLDIV)
- GOTO Q10
- +2 if '$DATA(RTERM)
- SET RTERM="NAME"
- DO PRT
- if $DATA(RTION)
- GOTO LOAD^RTSM1
- Q10 KILL RADPT,RTLOAD,RTMES1,RTERM
- +1 KILL RTCXX,RTLDIV,X,J,DUOUT,RTXX,RTSTART
- QUIT
- +2 ;
- LOAD SET DFN=$SELECT($DATA(^TMP("RTDFNSTART",+RTAPL)):^(+RTAPL)-1,1:0)
- +1 FOR DFN=DFN:0
- SET DFN=$ORDER(^DPT(DFN))
- if 'DFN
- QUIT
- IF $DATA(^DPT(DFN,0))
- IF $SELECT('RADPT:1,$DATA(^RADPT(DFN,0)):1,1:0)
- SET RTE=DFN_";DPT("
- DO RTTY^RTSM1
- SET ^TMP("RTDFNSTART",+RTAPL)=DFN
- +2 KILL DFN
- QUIT
- +3 ;
- PAT ;Patient Label Creation
- +1 IF RTERM'="NAME"
- DO PAT0
- IF 1
- +2 IF '$TEST
- DO PAT1
- +3 KILL RTRM0,RTRM1,DFN,RTNME,RTNME0,RTRM,RTTD,DFN
- QUIT
- +4 ;
- PAT0 FOR RTRM0=1:1
- SET RTRM=$PIECE(RTERM,"^",RTRM0)
- if RTRM=""
- QUIT
- Begin DoDot:1
- +1 SET RTTD=$SELECT($DATA(RTSTART):RTSTART,1:RTRM_"0000000")
- KILL RTSTART
- +2 SET RTRM1=0
- +3 FOR
- SET RTTD=$ORDER(^RTV(194.3,1,1,"AC",RTTD))
- if $EXTRACT(RTTD,1,2)'=RTRM!(RTTD="")
- QUIT
- Begin DoDot:2
- +4 SET DFN=0
- +5 FOR
- SET DFN=$ORDER(^RTV(194.3,1,1,"AC",RTTD,DFN))
- if 'DFN
- QUIT
- SET X=^(DFN)
- DO LB
- End DoDot:2
- End DoDot:1
- +6 QUIT
- PAT1 SET RTNME=""
- FOR RTNME0=0:0
- SET RTNME=$ORDER(^DPT("B",RTNME))
- if RTNME=""
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DPT("B",RTNME,DFN))
- if 'DFN
- QUIT
- if '$DATA(RTLDIV)
- DO LBL
- IF $DATA(RTLDIV)
- SET X=$ORDER(^DPT(DFN,"DIS",0))
- SET X=$SELECT('X:"",'$DATA(^(X,0)):"",X:$PIECE(^(0),"^",4),1:"")
- DO LB
- +1 QUIT
- LB IF $DATA(RTLDIV)
- SET RTLDV="^"_X_"^"
- IF RTLDIV'[RTLDV
- KILL X,RTLDV
- QUIT
- +1 ;
- +2 ;
- LBL IF $DATA(^DPT(DFN,0))
- IF $SELECT('$DATA(^(.35)):1,'^(.35):1,1:0)
- IF $SELECT('RADPT:1,$DATA(^RADPT(DFN,0)):1,1:0)
- SET RTE=DFN_";DPT("
- DO RTTY^RTSM1
- KILL RTE
- QUIT
- +1 QUIT
- +2 ;
- 11 ;;Inpatient Labels
- +1 SET RTLOAD="IN^RTSM3"
- GOTO ASK
- +2 ;
- IN ;Inpatient Label
- +1 SET RTWARD=""
- FOR RTWARD1=0:0
- SET RTWARD=$ORDER(^DPT("CN",RTWARD))
- if RTWARD=""
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DPT("CN",RTWARD,DFN))
- if 'DFN
- QUIT
- if $SELECT('RADPT:1,$DATA(^RADPT(DFN,0)):1,1:0)
- DO DFN
- +2 WRITE !!,"Printing Labels..."
- SET RTSORT=""
- +3 FOR RTSORT1=0:0
- SET RTSORT=$ORDER(^TMP($JOB,"RTSORT",RTSORT))
- if RTSORT=""
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^TMP($JOB,"RTSORT",RTSORT,DFN))
- if 'DFN
- QUIT
- SET RTE=DFN_";DPT("
- if $DATA(^DPT(DFN,.1))
- DO RTTY^RTSM1
- +4 KILL RTWARD,RTWARD1,DFN,RTE,RTSORT,RTSORT1
- +5 KILL RTXX,X1
- QUIT
- DFN if '$DATA(^DPT(DFN,0))
- QUIT
- SET X=^(0)
- IF RTERM'="NAME"
- SET X=$PIECE(^(0),"^",9)
- IF X
- if $DATA(RTERM($EXTRACT(X,8,9)))
- SET ^TMP($JOB,"RTSORT",$EXTRACT(X,8,9)_$EXTRACT(X,6,7)_$EXTRACT(X,1,5),DFN)=""
- QUIT
- +1 IF X
- SET ^TMP($JOB,"RTSORT",$PIECE(X,"^"),DFN)=""
- QUIT
- +2 QUIT
- +3 ;add check for barcode field, screen for virtual term?
- PRT KILL RTION
- SET DIC(0)="IAEMQ"
- SET DIC="^%ZIS(1,"
- SET DIC("A")="Select Label Printer: "
- SET DIC("S")="I $D(^(""SUBTYPE"")),$D(^%ZIS(2,+^(""SUBTYPE""),0)),$E(^(0))=""P"""
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET RTION=$PIECE(Y,"^",2)
- +1 QUIT
- +2 ;
