BCHDL2 ; IHS/TUCSON/LAB - DOWNLOAD TABLES [ 06/19/02 7:22 AM ]
;;1.0;IHS RPMS CHR SYSTEM;**14**;OCT 28, 1996
;IHS/CMI/LAB - tmp to xtmp
;
START ;
W:$D(IOF) @IOF
W !!?9,"**** DOWNLOAD STANDARD TABLES FOR REMOTE ****",!!
W "This routine is to be run whenever a CHR wants to download the standard ",!,"tables to the remote system.",!
W !,"The following tables will be downloaded in a format readable by the remote",!,"software:"
;W !!,"FILE",?25,"FILE NAME CREATED"
;W !,"AREA",?25,"chrarea.txt"
;W !,"SERVICE UNIT",?25,"chrsu.txt"
;W !,"FACILITY",?25,"chrfac.txt"
;W !,"COMMUNITY",?25,"chrcomm.txt"
W !,"PROGRAM",?25,"chrprog"_DT_".txt"
;W !,"TRIBE",?25,"chrtribe.txt"
W !,"HEALTH PROBLEM CODES",?25,"chrhlthprob"_DT_".txt"
W !,"SERVICE CODES",?25,"chrsrvcode"_DT_".txt"
W !,"REFERRAL CODES",?25,"chrrefcode"_DT_".txt"
W !,"FAMILY PLANNING CODE",?25,"chrfamplancode"_DT_".txt"
W !,"These file(s) will be placed in the same directory that all export"
W !,"files are placed. In most cases, that will be /usr/spool/uucppublic."
W !,"See your site manager for assistance in finding the files once it has"
W !,"been created.",!!
;
CONT ;
S DIR(0)="Y",DIR("A")="Do you wish to continue tables files",DIR("B")="N" K DA D ^DIR K DIR
G:$D(DIRUT) XIT
G:'Y XIT
;dump each table
AREA ;
;K ^TMP($J)
;W !!,"Downloading Area table"
;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTAREA(BCHX)) Q:BCHX'=+BCHX D
;.S R=""
;.S X=$P(^AUTTAREA(BCHX,0),U),Y=$P(^AUTTAREA(BCHX,0),U,2),Z=0
;.S R=Y_","_X_","_Z
;.S BCHC=BCHC+1,^TMP($J,"AREA",BCHC)=R
;.Q
;S XBGL="TMP("_$J_",""AREA"","
;S XBMED="F",XBFN="chrarea"_DT_".txt",XBTLE="SAVE OF AREA FOR CHR DOWNLOAD"
;S XBF=0,XBQ="N",XBFLT=1,XBE=$J
;D ^XBGSAVE
SU ;
;K ^TMP($J)
;W !!,"Downloading Service Unit table"
;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTSU(BCHX)) Q:BCHX'=+BCHX D
;.S R=""
;.S X=$P(^AUTTSU(BCHX,0),U),Y=$P(^AUTTSU(BCHX,0),U,4),Z=0
;.S R=Y_","_X_","_Z
;.S BCHC=BCHC+1,^TMP($J,"SU",BCHC)=R
;.Q
;S XBGL="TMP("_$J_",""SU"","
;S XBF=0,XBQ="N",XBFLT=1,XBE=$J
;D ^XBGSAVE
FAC ;
;K ^TMP($J)
;W !!,"Downloading Facility table"
;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTLOC(BCHX)) Q:BCHX'=+BCHX D
;.S R=""
;.S X=$P(^DIC(4,BCHX,0),U),Y=$P(^AUTTLOC(BCHX,0),U,10),Z=$S($P(^AUTTLOC(BCHX,0),U,21)]"":1,1:0)
;.S R=Y_","_X_","_Z
;.S BCHC=BCHC+1,^TMP($J,"LOC",BCHC)=R
;.Q
;S XBMED="F",XBFN="chrfac"_DT_".txt",XBTLE="SAVE OF FAC FOR CHR DOWNLOAD"
; S XBF=0,XBQ="N",XBFLT=1,XBE=$J
;D ^XBGSAVE
COMM ;
;K ^TMP($J)
;W !!,"Downloading Community table"
;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTCOM(BCHX)) Q:BCHX'=+BCHX D
;.S R=""
;.S X=$P(^AUTTCOM(BCHX,0),U),Y=$P(^AUTTCOM(BCHX,0),U,8),Z=0
;.S R=Y_","_X_","_Z
;.S BCHC=BCHC+1,^TMP($J,"COM",BCHC)=R
;.Q
;S XBGL="TMP("_$J_",""COM"","
;S XBMED="F",XBFN="chrcomm"_DT_".txt",XBTLE="SAVE OF COM FOR CHR DOWNLOAD"
;S XBF=0,XBQ="N",XBFLT=1,XBE=$J
;D ^XBGSAVE
TRIBE ;
;K ^TMP($J)
;W !!,"Downloading Tribe table"
;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTTRI(BCHX)) Q:BCHX'=+BCHX D
;.S R=""
;.S X=$P(^AUTTTRI(BCHX,0),U),Y=$P(^AUTTTRI(BCHX,0),U,2),Z=$P(^AUTTTRI(BCHX,0),U,4),Z=$S(Z="Y":1,1:0)
;.S R=Y_","_X_","_Z
;.S BCHC=BCHC+1,^TMP($J,"TRI",BCHC)=R
;.Q
;S XBGL="TMP("_$J_",""TRI"","
;S XBMED="F",XBFN="chrtribe"_DT_".txt",XBTLE="SAVE OF TRI FOR CHR DOWNLOAD"
;S XBF=0,XBQ="N",XBFLT=1,XBE=$J
;D ^XBGSAVE
PROG ;
K ^TMP($J)
W !!,"Downloading Program table"
S (BCHC,BCHX)=0 F S BCHX=$O(^BCHTPROG(BCHX)) Q:BCHX'=+BCHX D
.S R=""
.S X=$P(^BCHTPROG(BCHX,0),U),Y=$P(^BCHTPROG(BCHX,0),U,5),Z=0
.S R=Y_"|"_X_"|"_Z
.S BCHC=BCHC+1,^TMP($J,"PROG",BCHC)=R
.Q
S XBGL="TMP("_$J_",""PROG"","
S XBMED="F",XBFN="chrprog"_DT_".txt",XBTLE="SAVE OF PROG FOR CHR DOWNLOAD"
S XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
HP ;
K ^TMP($J)
W !!,"Downloading Health Problem table"
S (BCHC,BCHX)=0 F S BCHX=$O(^BCHTPROB(BCHX)) Q:BCHX'=+BCHX D
.S R=""
.S X=$P(^BCHTPROB(BCHX,0),U,2),Y=$P(^BCHTPROB(BCHX,0),U,1)
.S R=X_"|"_Y_"|"_$P(^BCHTPROB(BCHX,0),U,6)
.S BCHC=BCHC+1,^TMP($J,"PROB",BCHC)=R
.Q
S XBGL="TMP("_$J_",""PROB"","
S XBMED="F",XBFN="chrhlthprob"_DT_".txt",XBTLE="SAVE OF PROB FOR CHR DOWNLOAD"
S XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
SVC ;
K ^TMP($J)
W !!,"Downloading Service Code table"
S (BCHC,BCHX)=0 F S BCHX=$O(^BCHTSERV(BCHX)) Q:BCHX'=+BCHX D
.S R=""
.S X=$P(^BCHTSERV(BCHX,0),U,3),Y=$P(^BCHTSERV(BCHX,0),U,1)_"|"_$P(^BCHTSERV(BCHX,0),U,2)
.S R=X_"|"_Y
.S BCHC=BCHC+1,^TMP($J,"SERV",BCHC)=R
.Q
S XBGL="TMP("_$J_",""SERV"","
S XBMED="F",XBFN="chrsrvcode"_DT_".txt",XBTLE="SAVE OF SERV FOR CHR DOWNLOAD"
S XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
REF ;
K ^TMP($J)
W !!,"Downloading Referral table"
S (BCHC,BCHX)=0 F S BCHX=$O(^BCHTREF(BCHX)) Q:BCHX'=+BCHX D
.S R=""
.S X=$P(^BCHTREF(BCHX,0),U,2),Y=$P(^BCHTREF(BCHX,0),U,1),Z=$P(^BCHTREF(BCHX,0),U,3)
.S R=Z_"|"_Y_"|"_X
.S BCHC=BCHC+1,^TMP($J,"REF",BCHC)=R
.Q
S XBGL="TMP("_$J_",""REF"","
S XBMED="F",XBFN="chrrefcode"_DT_".txt",XBTLE="SAVE OF REFERRAL FOR CHR DOWNLOAD"
S XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
FPC ;
K ^TMP($J)
W !!,"Downloading FAMILY PLANNING CODES"
S (BCHC,BCHX)=0 F S BCHX=$O(^BCHTFPM(BCHX)) Q:BCHX'=+BCHX D
.S R=""
.S X=$P(^BCHTFPM(BCHX,0),U,2),Y=$P(^BCHTFPM(BCHX,0),U,1),Z=$P(^BCHTFPM(BCHX,0),U,3)
.S R=X_"|"_Y
.S BCHC=BCHC+1,^TMP($J,"FPM",BCHC)=R
.Q
S XBGL="TMP("_$J_",""FPM"","
S XBMED="F",XBFN="chrfamplancode"_DT_".txt",XBTLE="SAVE OF FPM FOR CHR DOWNLOAD"
S XBF=0,XBQ="N",XBFLT=1,XBE=$J
D ^XBGSAVE
XIT ;
K BCHX,BCHC
Q
QU(X) ;quote a string
I X]"" S X=""""_X_""""
Q X
;
BCHDL2 ; IHS/TUCSON/LAB - DOWNLOAD TABLES [ 06/19/02 7:22 AM ]
+1 ;;1.0;IHS RPMS CHR SYSTEM;**14**;OCT 28, 1996
+2 ;IHS/CMI/LAB - tmp to xtmp
+3 ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!?9,"**** DOWNLOAD STANDARD TABLES FOR REMOTE ****",!!
+3 WRITE "This routine is to be run whenever a CHR wants to download the standard ",!,"tables to the remote system.",!
+4 WRITE !,"The following tables will be downloaded in a format readable by the remote",!,"software:"
+5 ;W !!,"FILE",?25,"FILE NAME CREATED"
+6 ;W !,"AREA",?25,"chrarea.txt"
+7 ;W !,"SERVICE UNIT",?25,"chrsu.txt"
+8 ;W !,"FACILITY",?25,"chrfac.txt"
+9 ;W !,"COMMUNITY",?25,"chrcomm.txt"
+10 WRITE !,"PROGRAM",?25,"chrprog"_DT_".txt"
+11 ;W !,"TRIBE",?25,"chrtribe.txt"
+12 WRITE !,"HEALTH PROBLEM CODES",?25,"chrhlthprob"_DT_".txt"
+13 WRITE !,"SERVICE CODES",?25,"chrsrvcode"_DT_".txt"
+14 WRITE !,"REFERRAL CODES",?25,"chrrefcode"_DT_".txt"
+15 WRITE !,"FAMILY PLANNING CODE",?25,"chrfamplancode"_DT_".txt"
+16 WRITE !,"These file(s) will be placed in the same directory that all export"
+17 WRITE !,"files are placed. In most cases, that will be /usr/spool/uucppublic."
+18 WRITE !,"See your site manager for assistance in finding the files once it has"
+19 WRITE !,"been created.",!!
+20 ;
CONT ;
+1 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue tables files"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
GOTO XIT
+3 IF 'Y
GOTO XIT
+4 ;dump each table
AREA ;
+1 ;K ^TMP($J)
+2 ;W !!,"Downloading Area table"
+3 ;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTAREA(BCHX)) Q:BCHX'=+BCHX D
+4 ;.S R=""
+5 ;.S X=$P(^AUTTAREA(BCHX,0),U),Y=$P(^AUTTAREA(BCHX,0),U,2),Z=0
+6 ;.S R=Y_","_X_","_Z
+7 ;.S BCHC=BCHC+1,^TMP($J,"AREA",BCHC)=R
+8 ;.Q
+9 ;S XBGL="TMP("_$J_",""AREA"","
+10 ;S XBMED="F",XBFN="chrarea"_DT_".txt",XBTLE="SAVE OF AREA FOR CHR DOWNLOAD"
+11 ;S XBF=0,XBQ="N",XBFLT=1,XBE=$J
+12 ;D ^XBGSAVE
SU ;
+1 ;K ^TMP($J)
+2 ;W !!,"Downloading Service Unit table"
+3 ;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTSU(BCHX)) Q:BCHX'=+BCHX D
+4 ;.S R=""
+5 ;.S X=$P(^AUTTSU(BCHX,0),U),Y=$P(^AUTTSU(BCHX,0),U,4),Z=0
+6 ;.S R=Y_","_X_","_Z
+7 ;.S BCHC=BCHC+1,^TMP($J,"SU",BCHC)=R
+8 ;.Q
+9 ;S XBGL="TMP("_$J_",""SU"","
+10 ;S XBF=0,XBQ="N",XBFLT=1,XBE=$J
+11 ;D ^XBGSAVE
FAC ;
+1 ;K ^TMP($J)
+2 ;W !!,"Downloading Facility table"
+3 ;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTLOC(BCHX)) Q:BCHX'=+BCHX D
+4 ;.S R=""
+5 ;.S X=$P(^DIC(4,BCHX,0),U),Y=$P(^AUTTLOC(BCHX,0),U,10),Z=$S($P(^AUTTLOC(BCHX,0),U,21)]"":1,1:0)
+6 ;.S R=Y_","_X_","_Z
+7 ;.S BCHC=BCHC+1,^TMP($J,"LOC",BCHC)=R
+8 ;.Q
+9 ;S XBMED="F",XBFN="chrfac"_DT_".txt",XBTLE="SAVE OF FAC FOR CHR DOWNLOAD"
+10 ; S XBF=0,XBQ="N",XBFLT=1,XBE=$J
+11 ;D ^XBGSAVE
COMM ;
+1 ;K ^TMP($J)
+2 ;W !!,"Downloading Community table"
+3 ;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTCOM(BCHX)) Q:BCHX'=+BCHX D
+4 ;.S R=""
+5 ;.S X=$P(^AUTTCOM(BCHX,0),U),Y=$P(^AUTTCOM(BCHX,0),U,8),Z=0
+6 ;.S R=Y_","_X_","_Z
+7 ;.S BCHC=BCHC+1,^TMP($J,"COM",BCHC)=R
+8 ;.Q
+9 ;S XBGL="TMP("_$J_",""COM"","
+10 ;S XBMED="F",XBFN="chrcomm"_DT_".txt",XBTLE="SAVE OF COM FOR CHR DOWNLOAD"
+11 ;S XBF=0,XBQ="N",XBFLT=1,XBE=$J
+12 ;D ^XBGSAVE
TRIBE ;
+1 ;K ^TMP($J)
+2 ;W !!,"Downloading Tribe table"
+3 ;S (BCHC,BCHX)=0 F S BCHX=$O(^AUTTTRI(BCHX)) Q:BCHX'=+BCHX D
+4 ;.S R=""
+5 ;.S X=$P(^AUTTTRI(BCHX,0),U),Y=$P(^AUTTTRI(BCHX,0),U,2),Z=$P(^AUTTTRI(BCHX,0),U,4),Z=$S(Z="Y":1,1:0)
+6 ;.S R=Y_","_X_","_Z
+7 ;.S BCHC=BCHC+1,^TMP($J,"TRI",BCHC)=R
+8 ;.Q
+9 ;S XBGL="TMP("_$J_",""TRI"","
+10 ;S XBMED="F",XBFN="chrtribe"_DT_".txt",XBTLE="SAVE OF TRI FOR CHR DOWNLOAD"
+11 ;S XBF=0,XBQ="N",XBFLT=1,XBE=$J
+12 ;D ^XBGSAVE
PROG ;
+1 KILL ^TMP($JOB)
+2 WRITE !!,"Downloading Program table"
+3 SET (BCHC,BCHX)=0
FOR
SET BCHX=$ORDER(^BCHTPROG(BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+4 SET R=""
+5 SET X=$PIECE(^BCHTPROG(BCHX,0),U)
SET Y=$PIECE(^BCHTPROG(BCHX,0),U,5)
SET Z=0
+6 SET R=Y_"|"_X_"|"_Z
+7 SET BCHC=BCHC+1
SET ^TMP($JOB,"PROG",BCHC)=R
+8 QUIT
End DoDot:1
+9 SET XBGL="TMP("_$JOB_",""PROG"","
+10 SET XBMED="F"
SET XBFN="chrprog"_DT_".txt"
SET XBTLE="SAVE OF PROG FOR CHR DOWNLOAD"
+11 SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+12 DO ^XBGSAVE
HP ;
+1 KILL ^TMP($JOB)
+2 WRITE !!,"Downloading Health Problem table"
+3 SET (BCHC,BCHX)=0
FOR
SET BCHX=$ORDER(^BCHTPROB(BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+4 SET R=""
+5 SET X=$PIECE(^BCHTPROB(BCHX,0),U,2)
SET Y=$PIECE(^BCHTPROB(BCHX,0),U,1)
+6 SET R=X_"|"_Y_"|"_$PIECE(^BCHTPROB(BCHX,0),U,6)
+7 SET BCHC=BCHC+1
SET ^TMP($JOB,"PROB",BCHC)=R
+8 QUIT
End DoDot:1
+9 SET XBGL="TMP("_$JOB_",""PROB"","
+10 SET XBMED="F"
SET XBFN="chrhlthprob"_DT_".txt"
SET XBTLE="SAVE OF PROB FOR CHR DOWNLOAD"
+11 SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+12 DO ^XBGSAVE
SVC ;
+1 KILL ^TMP($JOB)
+2 WRITE !!,"Downloading Service Code table"
+3 SET (BCHC,BCHX)=0
FOR
SET BCHX=$ORDER(^BCHTSERV(BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+4 SET R=""
+5 SET X=$PIECE(^BCHTSERV(BCHX,0),U,3)
SET Y=$PIECE(^BCHTSERV(BCHX,0),U,1)_"|"_$PIECE(^BCHTSERV(BCHX,0),U,2)
+6 SET R=X_"|"_Y
+7 SET BCHC=BCHC+1
SET ^TMP($JOB,"SERV",BCHC)=R
+8 QUIT
End DoDot:1
+9 SET XBGL="TMP("_$JOB_",""SERV"","
+10 SET XBMED="F"
SET XBFN="chrsrvcode"_DT_".txt"
SET XBTLE="SAVE OF SERV FOR CHR DOWNLOAD"
+11 SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+12 DO ^XBGSAVE
REF ;
+1 KILL ^TMP($JOB)
+2 WRITE !!,"Downloading Referral table"
+3 SET (BCHC,BCHX)=0
FOR
SET BCHX=$ORDER(^BCHTREF(BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+4 SET R=""
+5 SET X=$PIECE(^BCHTREF(BCHX,0),U,2)
SET Y=$PIECE(^BCHTREF(BCHX,0),U,1)
SET Z=$PIECE(^BCHTREF(BCHX,0),U,3)
+6 SET R=Z_"|"_Y_"|"_X
+7 SET BCHC=BCHC+1
SET ^TMP($JOB,"REF",BCHC)=R
+8 QUIT
End DoDot:1
+9 SET XBGL="TMP("_$JOB_",""REF"","
+10 SET XBMED="F"
SET XBFN="chrrefcode"_DT_".txt"
SET XBTLE="SAVE OF REFERRAL FOR CHR DOWNLOAD"
+11 SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+12 DO ^XBGSAVE
FPC ;
+1 KILL ^TMP($JOB)
+2 WRITE !!,"Downloading FAMILY PLANNING CODES"
+3 SET (BCHC,BCHX)=0
FOR
SET BCHX=$ORDER(^BCHTFPM(BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+4 SET R=""
+5 SET X=$PIECE(^BCHTFPM(BCHX,0),U,2)
SET Y=$PIECE(^BCHTFPM(BCHX,0),U,1)
SET Z=$PIECE(^BCHTFPM(BCHX,0),U,3)
+6 SET R=X_"|"_Y
+7 SET BCHC=BCHC+1
SET ^TMP($JOB,"FPM",BCHC)=R
+8 QUIT
End DoDot:1
+9 SET XBGL="TMP("_$JOB_",""FPM"","
+10 SET XBMED="F"
SET XBFN="chrfamplancode"_DT_".txt"
SET XBTLE="SAVE OF FPM FOR CHR DOWNLOAD"
+11 SET XBF=0
SET XBQ="N"
SET XBFLT=1
SET XBE=$JOB
+12 DO ^XBGSAVE
XIT ;
+1 KILL BCHX,BCHC
+2 QUIT
QU(X) ;quote a string
+1 IF X]""
SET X=""""_X_""""
+2 QUIT X
+3 ;
