- RTSM1 ;TROY ISC/MJK,PKE-Record File Initialization Utility ; 5/21/87 4:06 PM ; 1/7/03 11:51am
- ;;2.0;Record Tracking;**4,14,34**;10/22/91
- RTTY ;
- F RTHOLD=0:0 S RTHOLD=+$O(RTHOLD(RTHOLD)) Q:'RTHOLD S RTTY=RTHOLD(RTHOLD) S RT=+$O(^RT("AT",+RTTY,RTE,0)) D CREATE:'RT,LBL:RTION]""
- S RTCNTP=RTCNTP+1 I '(RTCNTP#50) H $S(RTION="":0,1:$S($D(^DIC(195.4,1,"COOL")):^("COOL"),1:0))*60 I '(RTCNTP#100) W !,RTCNTP," patients processed. " D NOW^%DTC S Y=$E(%,1,12) D DT^DIQ
- K RT,RTTY Q
- ;
- CREATE ;
- D CREATE^RTDPA1 S:RT RTCNTR=RTCNTR+1 Q
- ;
- LBL ;
- H 8 S RTFMT=+$P(RTTY,"^",5) I $D(^DIC(194.4,RTFMT,0)) S IOP=RTION D ^%ZIS K IOP S RTNUM=1,RTIFN=RT U IO D PRT^RTL1 S RTCNTL=RTCNTL+1 Q
- ;
- LOAD ;Entry load record from DPT
- ;MUST:
- ; RTAPL
- ; RTMES
- ; RTLOAD
- ; RTDIV
- ; RADPT
- ;
- ;optional:
- ; RTION - 'name' of printer to labels on (null for no labels)
- ; RTERM - list of terminal digits or 'NAME'
- ;
- D SEL^RTSM2 G Q:'$D(RTHOLD) S RTVAR="RADPT^RTDIV^RTMES1^RTLOAD^RTHOLD^RTAPL"_$S($D(RTION):"^RTION",1:"")_$S($D(RTERM):"^RTERM",1:"")_$S($D(RTSTART):"^RTSTART",1:""),RTPGM="START^RTSM1" D ZIS^RTUTL G Q:POP
- START K ^TMP($J),RTSHOW,RTADM S (RTCNTR,RTCNTP,RTCNTL)=0,RTBKGRD="" D HOLD S:'$D(RTION) RTION=""
- I $D(RTERM),RTERM'="NAME" F I=1:1 Q:$P(RTERM,"^",I)="" S RTERM($P(RTERM,"^",I))=""
- W @IOF,!,RTMES1,!!?5,"START TIME: " D NOW^%DTC S Y=$E(%,1,12) D DT^DIQ W !!,"Log",!,"---" D @RTLOAD
- W !,"[TOTAL PATIENTS PROCESSED : ",RTCNTP,"]"
- W !,"[TOTAL NUMBER OF RECORDS CREATED: ",RTCNTR,"]"
- W !,"[TOTAL RECORD LABELS CREATED : ",RTCNTL,"]"
- W !!?5,"STOP TIME: " D NOW^%DTC S Y=$E(%,1,12) D DT^DIQ W !
- I RTION]"" S IOP=RTION D ^%ZIS K IOP U IO W !
- Q K ^TMP($J),RTERM,RADPT,RTHOLD,RTION,RTMES1,RTLOAD,RTN,RTHOLD,RTBKGRD,RTCNTP,RTCNTL,RTCNTR,RTTY D CLOSE^RTUTL
- K DA,D0,DIC,DIE,DR,I,I1,RTE,RTPGM,RTVAR,RTBC,RTJ,RTPGM,RTXX,X1,Y Q
- HOLD F I1=1:1 Q:'$P(RTHOLD,"^",I1) S Y=$P(RTHOLD,"^",I1) D TYPE1^RTUTL S:$D(RTTY) RTHOLD(Y)=RTTY
- K I1,RTTY Q
- ;
- ;
- SORT D NOW^%DTC S $P(^RTV(194.3,1,0),"^",2,3)=%_"^"
- S (DFN,LDFN)=$S($D(^RTV(194.3,1,1,0)):+$P(^(0),"^",3),1:0)
- ;just set it the first time
- I 'DFN D ONETIM^RTSM4,QS Q
- ;check for new records
- F S DFN=$O(^DPT(DFN)) Q:'DFN DO
- .S LDFN=DFN
- .I '$D(^RTV(194.3,1,1,DFN,0)) D FILE W:'$D(ZTQUEUED) "." Q
- ;verify/update old records
- S (RTCT,TD)=0 F S TD=$O(^RTV(194.3,1,1,"AC",TD)) Q:TD="" DO
- .S DFN=0 F S DFN=$O(^RTV(194.3,1,1,"AC",TD,DFN)) Q:'DFN DO
- . .I '$D(^DPT(DFN,0)) K ^RTV(194.3,1,1,"AC",TD,DFN) S DA(1)=1,DA=DFN,DIK="^RTV(194.3,1,1," D ^DIK K DE,DQ Q
- . .S SSN=$P(^DPT(DFN,0),"^",9),RTCT=RTCT+1
- . .I '$D(ZTQUEUED),DFN#1000=0 W ","
- . .I TD'=($E(SSN,8,9)_$E(SSN,6,7)_$E(SSN,1,5)) DO
- . . .;get rid of old xref and entry
- . . .K ^RTV(194.3,1,1,"AC",TD,DFN)
- . . .S DA(1)=1,DA=DFN,DIK="^RTV(194.3,1,1," D ^DIK K DE,DQ
- . . .;update new one
- . . .D FILE Q
- QS ;update for next time
- D NOW^%DTC S $P(^RTV(194.3,1,0),"^",3)=%
- S $P(^RTV(194.3,1,1,0),"^",3,4)=LDFN_"^"_RTCT
- K RTCT,LDFN,TD,DFN,SSN,DA,DIC,DIK,DR Q
- ;
- FILE I '$D(^RTV(194.3,1,1,0)) S ^(0)="^194.31PA^0^0"
- S DIC="^RTV(194.3,1,1,",DIC(0)="L",DIC("DR")="1///`"_DFN
- K DD,DO S (X,DINUM)=DFN D FILE^DICN Q
- ;
- 12 ;;Create Terminal Digit Sort Global
- W !!,"RECORD TRACKING SORT GLOBAL Compilation" S Y=""
- I $D(^RTV(194.3,1,0)),$P(^(0),"^",2),$P(^(0),"^",3) DO
- .W !!,*7,"The SORT global already exists.",!?11,"Compilation started: "
- .S Y1=$P(^(0),"^",2,3),Y=$P(Y1,"^") D DT^DIQ ;naked rtv(194.3,1,0)
- .I $S('$D(^RTV(194.3,1,1,0)):1,'$P(^(0),"^",3):1,1:0) Q
- .W !?8,"Last patient processed: ",$P(^(0),"^",3) ;nakd rtv(194.3,1,1,0
- .W !?8," Compilation finished: "
- .S Y=$P(Y1,"^",2) D DT^DIQ
- .K Y
- S RTRD(1)="Yes^queue job",RTRD(2)="No^not queue job",RTRD(0)="S",RTRD("B")=2,RTRD("A")="Do you wish to queue a job that will "_$S('$D(Y):"Update-",1:"")_"compile this global? " D SET^RTRD K RTRD G Q12:$E(X)'="Y"
- S RTVAR="",(ION,IOM,IOST)="",RTPGM="SORT^RTSM1" D Q^RTUTL K RTVAR,RTPGM S IOP="" D ^%ZIS
- ;
- Q12 K IOP,X1,Y,RTVAR,RTPGM,X,X1,Y1 Q
- ;
- 13 ;;Delete Terminal Digit Sort Global
- W !,"It is not usually necessary to delete this global, just compile it"
- S RTRD(0)="S",RTRD(1)="Yes^delete global",RTRD(2)="No^keep global",RTRD("A")="Are you sure you want to delete the RT SORT GLOBAL entries? ",RTRD("B")=2 D SET^RTRD K RTRD
- I $E(X)="Y" DO
- .K ^RTV(194.3,1,1)
- .;reset nodes
- .S ^RTV(194.3,1,0)="TERMINAL DIGITS^^"
- .S ^RTV(194.3,1,1,0)="^194.31PA^^"
- .W !?3,"...deleted"
- K Y,X,X1 Q
- ;
- ;set logic 194.3 ac xref
- S1943 I $D(^DPT(X,0)) S SSN=$P(^(0),"^",9),DOB=$P(^(0),"^",3) I SSN,DOB DO
- .S DVBDIS=$O(^DPT(X,"DIS",0)) I 'DVBDIS
- .E S DVBDIS=$S('$D(^(DVBDIS,0)):"",1:$P(^(0),"^",4)) ;nakd dpt(x,dis,0)
- .S ^RTV(194.3,1,1,"AC",$E(SSN,8,9)_$E(SSN,6,7)_$E(SSN,1,5),X)=DVBDIS
- K SSN,DOB,DVBDIS Q
- ;
- ;kill logic 194.3 ac xref
- K1943 I $D(^DPT(X,0)) S SSN=$P(^(0),"^",9),DOB=$P(^(0),"^",3) I SSN,DOB DO
- .K ^RTV(194.3,1,1,"AC",$E(SSN,8,9)_$E(SSN,6,7)_$E(SSN,1,5),X)
- K SSN,DOB Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTSM1 4997 printed Jan 18, 2025@03:35:53 Page 2
- RTSM1 ;TROY ISC/MJK,PKE-Record File Initialization Utility ; 5/21/87 4:06 PM ; 1/7/03 11:51am
- +1 ;;2.0;Record Tracking;**4,14,34**;10/22/91
- RTTY ;
- +1 FOR RTHOLD=0:0
- SET RTHOLD=+$ORDER(RTHOLD(RTHOLD))
- if 'RTHOLD
- QUIT
- SET RTTY=RTHOLD(RTHOLD)
- SET RT=+$ORDER(^RT("AT",+RTTY,RTE,0))
- if 'RT
- DO CREATE
- if RTION]""
- DO LBL
- +2 SET RTCNTP=RTCNTP+1
- IF '(RTCNTP#50)
- HANG $SELECT(RTION="":0,1:$SELECT($DATA(^DIC(195.4,1,"COOL")):^("COOL"),1:0))*60
- IF '(RTCNTP#100)
- WRITE !,RTCNTP," patients processed. "
- DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- DO DT^DIQ
- +3 KILL RT,RTTY
- QUIT
- +4 ;
- CREATE ;
- +1 DO CREATE^RTDPA1
- if RT
- SET RTCNTR=RTCNTR+1
- QUIT
- +2 ;
- LBL ;
- +1 HANG 8
- SET RTFMT=+$PIECE(RTTY,"^",5)
- IF $DATA(^DIC(194.4,RTFMT,0))
- SET IOP=RTION
- DO ^%ZIS
- KILL IOP
- SET RTNUM=1
- SET RTIFN=RT
- USE IO
- DO PRT^RTL1
- SET RTCNTL=RTCNTL+1
- QUIT
- +2 ;
- LOAD ;Entry load record from DPT
- +1 ;MUST:
- +2 ; RTAPL
- +3 ; RTMES
- +4 ; RTLOAD
- +5 ; RTDIV
- +6 ; RADPT
- +7 ;
- +8 ;optional:
- +9 ; RTION - 'name' of printer to labels on (null for no labels)
- +10 ; RTERM - list of terminal digits or 'NAME'
- +11 ;
- +12 DO SEL^RTSM2
- if '$DATA(RTHOLD)
- GOTO Q
- SET RTVAR="RADPT^RTDIV^RTMES1^RTLOAD^RTHOLD^RTAPL"_$SELECT($DATA(RTION):"^RTION",1:"")_$SELECT($DATA(RTERM):"^RTERM",1:"")_$SELECT($DATA(RTSTART):"^RTSTART",1:"")
- SET RTPGM="START^RTSM1"
- DO ZIS^RTUTL
- if POP
- GOTO Q
- START KILL ^TMP($JOB),RTSHOW,RTADM
- SET (RTCNTR,RTCNTP,RTCNTL)=0
- SET RTBKGRD=""
- DO HOLD
- if '$DATA(RTION)
- SET RTION=""
- +1 IF $DATA(RTERM)
- IF RTERM'="NAME"
- FOR I=1:1
- if $PIECE(RTERM,"^",I)=""
- QUIT
- SET RTERM($PIECE(RTERM,"^",I))=""
- +2 WRITE @IOF,!,RTMES1,!!?5,"START TIME: "
- DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- DO DT^DIQ
- WRITE !!,"Log",!,"---"
- DO @RTLOAD
- +3 WRITE !,"[TOTAL PATIENTS PROCESSED : ",RTCNTP,"]"
- +4 WRITE !,"[TOTAL NUMBER OF RECORDS CREATED: ",RTCNTR,"]"
- +5 WRITE !,"[TOTAL RECORD LABELS CREATED : ",RTCNTL,"]"
- +6 WRITE !!?5,"STOP TIME: "
- DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- DO DT^DIQ
- WRITE !
- +7 IF RTION]""
- SET IOP=RTION
- DO ^%ZIS
- KILL IOP
- USE IO
- WRITE !
- Q KILL ^TMP($JOB),RTERM,RADPT,RTHOLD,RTION,RTMES1,RTLOAD,RTN,RTHOLD,RTBKGRD,RTCNTP,RTCNTL,RTCNTR,RTTY
- DO CLOSE^RTUTL
- +1 KILL DA,D0,DIC,DIE,DR,I,I1,RTE,RTPGM,RTVAR,RTBC,RTJ,RTPGM,RTXX,X1,Y
- QUIT
- HOLD FOR I1=1:1
- if '$PIECE(RTHOLD,"^",I1)
- QUIT
- SET Y=$PIECE(RTHOLD,"^",I1)
- DO TYPE1^RTUTL
- if $DATA(RTTY)
- SET RTHOLD(Y)=RTTY
- +1 KILL I1,RTTY
- QUIT
- +2 ;
- +3 ;
- SORT DO NOW^%DTC
- SET $PIECE(^RTV(194.3,1,0),"^",2,3)=%_"^"
- +1 SET (DFN,LDFN)=$SELECT($DATA(^RTV(194.3,1,1,0)):+$PIECE(^(0),"^",3),1:0)
- +2 ;just set it the first time
- +3 IF 'DFN
- DO ONETIM^RTSM4
- DO QS
- QUIT
- +4 ;check for new records
- +5 FOR
- SET DFN=$ORDER(^DPT(DFN))
- if 'DFN
- QUIT
- Begin DoDot:1
- +6 SET LDFN=DFN
- +7 IF '$DATA(^RTV(194.3,1,1,DFN,0))
- DO FILE
- if '$DATA(ZTQUEUED)
- WRITE "."
- QUIT
- End DoDot:1
- +8 ;verify/update old records
- +9 SET (RTCT,TD)=0
- FOR
- SET TD=$ORDER(^RTV(194.3,1,1,"AC",TD))
- if TD=""
- QUIT
- Begin DoDot:1
- +10 SET DFN=0
- FOR
- SET DFN=$ORDER(^RTV(194.3,1,1,"AC",TD,DFN))
- if 'DFN
- QUIT
- Begin DoDot:2
- +11 IF '$DATA(^DPT(DFN,0))
- KILL ^RTV(194.3,1,1,"AC",TD,DFN)
- SET DA(1)=1
- SET DA=DFN
- SET DIK="^RTV(194.3,1,1,"
- DO ^DIK
- KILL DE,DQ
- QUIT
- +12 SET SSN=$PIECE(^DPT(DFN,0),"^",9)
- SET RTCT=RTCT+1
- +13 IF '$DATA(ZTQUEUED)
- IF DFN#1000=0
- WRITE ","
- +14 IF TD'=($EXTRACT(SSN,8,9)_$EXTRACT(SSN,6,7)_$EXTRACT(SSN,1,5))
- Begin DoDot:3
- +15 ;get rid of old xref and entry
- +16 KILL ^RTV(194.3,1,1,"AC",TD,DFN)
- +17 SET DA(1)=1
- SET DA=DFN
- SET DIK="^RTV(194.3,1,1,"
- DO ^DIK
- KILL DE,DQ
- +18 ;update new one
- +19 DO FILE
- QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- QS ;update for next time
- +1 DO NOW^%DTC
- SET $PIECE(^RTV(194.3,1,0),"^",3)=%
- +2 SET $PIECE(^RTV(194.3,1,1,0),"^",3,4)=LDFN_"^"_RTCT
- +3 KILL RTCT,LDFN,TD,DFN,SSN,DA,DIC,DIK,DR
- QUIT
- +4 ;
- FILE IF '$DATA(^RTV(194.3,1,1,0))
- SET ^(0)="^194.31PA^0^0"
- +1 SET DIC="^RTV(194.3,1,1,"
- SET DIC(0)="L"
- SET DIC("DR")="1///`"_DFN
- +2 KILL DD,DO
- SET (X,DINUM)=DFN
- DO FILE^DICN
- QUIT
- +3 ;
- 12 ;;Create Terminal Digit Sort Global
- +1 WRITE !!,"RECORD TRACKING SORT GLOBAL Compilation"
- SET Y=""
- +2 IF $DATA(^RTV(194.3,1,0))
- IF $PIECE(^(0),"^",2)
- IF $PIECE(^(0),"^",3)
- Begin DoDot:1
- +3 WRITE !!,*7,"The SORT global already exists.",!?11,"Compilation started: "
- +4 ;naked rtv(194.3,1,0)
- SET Y1=$PIECE(^(0),"^",2,3)
- SET Y=$PIECE(Y1,"^")
- DO DT^DIQ
- +5 IF $SELECT('$DATA(^RTV(194.3,1,1,0)):1,'$PIECE(^(0),"^",3):1,1:0)
- QUIT
- +6 ;nakd rtv(194.3,1,1,0
- WRITE !?8,"Last patient processed: ",$PIECE(^(0),"^",3)
- +7 WRITE !?8," Compilation finished: "
- +8 SET Y=$PIECE(Y1,"^",2)
- DO DT^DIQ
- +9 KILL Y
- End DoDot:1
- +10 SET RTRD(1)="Yes^queue job"
- SET RTRD(2)="No^not queue job"
- SET RTRD(0)="S"
- SET RTRD("B")=2
- SET RTRD("A")="Do you wish to queue a job that will "_$SELECT('$DATA(Y):"Update-",1:"")_"compile this global? "
- DO SET^RTRD
- KILL RTRD
- if $EXTRACT(X)'="Y"
- GOTO Q12
- +11 SET RTVAR=""
- SET (ION,IOM,IOST)=""
- SET RTPGM="SORT^RTSM1"
- DO Q^RTUTL
- KILL RTVAR,RTPGM
- SET IOP=""
- DO ^%ZIS
- +12 ;
- Q12 KILL IOP,X1,Y,RTVAR,RTPGM,X,X1,Y1
- QUIT
- +1 ;
- 13 ;;Delete Terminal Digit Sort Global
- +1 WRITE !,"It is not usually necessary to delete this global, just compile it"
- +2 SET RTRD(0)="S"
- SET RTRD(1)="Yes^delete global"
- SET RTRD(2)="No^keep global"
- SET RTRD("A")="Are you sure you want to delete the RT SORT GLOBAL entries? "
- SET RTRD("B")=2
- DO SET^RTRD
- KILL RTRD
- +3 IF $EXTRACT(X)="Y"
- Begin DoDot:1
- +4 KILL ^RTV(194.3,1,1)
- +5 ;reset nodes
- +6 SET ^RTV(194.3,1,0)="TERMINAL DIGITS^^"
- +7 SET ^RTV(194.3,1,1,0)="^194.31PA^^"
- +8 WRITE !?3,"...deleted"
- End DoDot:1
- +9 KILL Y,X,X1
- QUIT
- +10 ;
- +11 ;set logic 194.3 ac xref
- S1943 IF $DATA(^DPT(X,0))
- SET SSN=$PIECE(^(0),"^",9)
- SET DOB=$PIECE(^(0),"^",3)
- IF SSN
- IF DOB
- Begin DoDot:1
- +1 SET DVBDIS=$ORDER(^DPT(X,"DIS",0))
- IF 'DVBDIS
- +2 ;nakd dpt(x,dis,0)
- IF '$TEST
- SET DVBDIS=$SELECT('$DATA(^(DVBDIS,0)):"",1:$PIECE(^(0),"^",4))
- +3 SET ^RTV(194.3,1,1,"AC",$EXTRACT(SSN,8,9)_$EXTRACT(SSN,6,7)_$EXTRACT(SSN,1,5),X)=DVBDIS
- End DoDot:1
- +4 KILL SSN,DOB,DVBDIS
- QUIT
- +5 ;
- +6 ;kill logic 194.3 ac xref
- K1943 IF $DATA(^DPT(X,0))
- SET SSN=$PIECE(^(0),"^",9)
- SET DOB=$PIECE(^(0),"^",3)
- IF SSN
- IF DOB
- Begin DoDot:1
- +1 KILL ^RTV(194.3,1,1,"AC",$EXTRACT(SSN,8,9)_$EXTRACT(SSN,6,7)_$EXTRACT(SSN,1,5),X)
- End DoDot:1
- +2 KILL SSN,DOB
- QUIT