GECSXBLD ;WISC/RFJ-map data into template map ;01 Nov 93
;;2.0;GCS;;MAR 14, 1995
Q
;
;
MAPDATA(GECSDA) ; map data to template
; return 1 if code sheet is built, 0 if not built
N %,%H,%I,CODESHET,DA,DA1,DATA,DELIMITR,FIELD,GECSDATE,GECSEND,GECSFLAG,GECSLINE,GECSMAP,GECSNOD1,GECSNOD2,GECSOT,GECSTNM,I,N,PIECE,SUB1,SUB2,X,Y
;
; keypunched code sheet
K CODESHET
I $P($G(^GECS(2100,GECSDA,0)),"^",11)="[GECS KEYPUNCH]" D Q GECSFLAG
. S %=0 F I=0:1 S %=$O(^GECS(2100,GECSDA,"KEY",%)) Q:%="" S CODESHET(I)=^(%,0)
. I I=0 W !,"NOTHING TO KEYPUNCH." D KILLCS^GECSPUR1(GECSDA) W " << CODE SHEET DELETED >>" S GECSFLAG=0 Q
. S %=$$SHEET,GECSFLAG=1
;
; fill in fields code sheet
; set gecsot variable to execute output transform
S GECSOT=""
; move code sheet field data into variable data
K DATA
S SUB1="" F S SUB1=$O(^GECS(2100,GECSDA,SUB1)) Q:SUB1="" I SUB1'="CODE" S:$D(^(SUB1))'["0" DATA(SUB1)=^(SUB1) I $D(^GECS(2100,GECSDA,SUB1,0)) D
. S DA1=0 F S DA1=$O(^GECS(2100,GECSDA,SUB1,DA1)) Q:'DA1 D
. . S SUB2="" F S SUB2=$O(^GECS(2100,GECSDA,SUB1,DA1,SUB2)) Q:SUB2="" S:$D(^GECS(2100,GECSDA,SUB1,DA1,SUB2)) DATA(SUB1,DA1,SUB2)=^(SUB2)
;
; get template map
S GECSTNM=$P(DATA(0),"^",11),GECSTNM=$E(GECSTNM,2,$L(GECSTNM)-1) I GECSTNM="" W !,"CODE SHEET ",$P(DATA(0),"^")," DOES NOT HAVE A TEMPLATE MAP DEFINED." Q 0
S %=$O(^DIE("B",GECSTNM,0)) I '% W !,"INPUT TEMPLATE ",GECSTNM," NOT FOUND." Q 0
D GETMAP^GECSXMAP(%) I '$D(GECSMAP) Q 0
;
S GECSEND=80,DELIMITR=""
; put code sheet specific code here!!!
I $P(DATA(0),"^",2)="VOL" S GECSEND=81
I $P(DATA(0),"^",2)="FMS" S DELIMITR="^",GECSEND=240
I $P(DATA(0),"^",2)="FEN" S DELIMITR=".",GECSEND=240
; end of code sheet specific code
;
; build code sheet with data
; set da for output transform
S DA=GECSDA
K GECSFLAG
S (GECSLINE,GECSNOD1)=0 F S GECSNOD1=$O(GECSMAP(GECSNOD1)) Q:'GECSNOD1 D
. ; single field (not multiple)
. I GECSMAP(GECSNOD1)'["," D Q
. . F PIECE=1:1 S FIELD=$P(GECSMAP(GECSNOD1),"\",PIECE) Q:FIELD="" D Q:$G(GECSFLAG)
. . . S SUB1=$P(FIELD,";",2)
. . . S Y=$P($G(DATA(SUB1)),"^",$P(FIELD,";",3))
. . . D SETLINE(2100,+FIELD)
. ; multiple field
. S SUB1=$P(GECSMAP(GECSNOD1),",",2)
. S DA1=0 F S DA1=$O(DATA(SUB1,DA1)) Q:'DA1 S GECSNOD2=0 F S GECSNOD2=$O(GECSMAP(GECSNOD1,GECSNOD2)) Q:'GECSNOD2 D
. . F PIECE=1:1 S FIELD=$P(GECSMAP(GECSNOD1,GECSNOD2),"\",PIECE) Q:FIELD="" D Q:$G(GECSFLAG)
. . . S SUB2=$P(FIELD,";",2)
. . . S Y=$P($G(DATA(SUB1,DA1,SUB2)),"^",$P(FIELD,";",3))
. . . D SETLINE(+$P(GECSMAP(GECSNOD1),",",3),+FIELD)
;
; put code sheet specific code here (after code sheets have been built)
; reformat for amis
I $P(DATA(0),"^",2)="AMS" D AMIS
; end of code sheet specific code
Q $$SHEET
;
;
SHEET() ; move code sheets to code node
D NOW^%DTC S GECSDATE=%
K ^GECS(2100,GECSDA,"CODE")
S GECSLINE="" F I=1:1 S GECSLINE=$O(CODESHET(GECSLINE)) Q:GECSLINE="" S ^GECS(2100,GECSDA,"CODE",I,0)=CODESHET(GECSLINE)
S I=I-1,^GECS(2100,GECSDA,"CODE",0)="^^"_I_"^"_I_"^"_$P(GECSDATE,".")_"^^"
D PRINT^GECSUTIL(GECSDA)
Q 1
;
;
SETLINE(FILE,FIELD) ; build codeshet array with data in y
I $D(^DD(FILE,+FIELD,2.1)),^(2.1)["GECSOT" X ^(2.1)
S CODESHET(GECSLINE)=$G(CODESHET(GECSLINE))_$S($G(CODESHET(GECSLINE))="":"",$G(CODESHET(GECSLINE))=("LIN^"_$C(126)):"",$P(DATA(0),"^",2)="FEN"&(Y="$"):"",1:DELIMITR)_Y
; for fms, put each segment on a new line
I $P(DATA(0),"^",2)="FMS",Y=$C(126),$G(CODESHET(GECSLINE))'=("LIN^"_$C(126)) S GECSLINE=GECSLINE+1
I $L($G(CODESHET(GECSLINE)))>GECSEND S CODESHET(GECSLINE+1)=$E(CODESHET(GECSLINE),GECSEND+1,999),CODESHET(GECSLINE)=$E(CODESHET(GECSLINE),1,GECSEND),GECSLINE=GECSLINE+1
I Y="$" S GECSFLAG=1
Q
;
;
AMIS ; reformat for amis
N %,CHAR,LINE,OLDCODE,X
; move code sheet (in codeshet) to temp variable for processing
K OLDCODE S %="" F S %=$O(CODESHET(%)) Q:%="" S OLDCODE(%)=CODESHET(%)
K CODESHET S GECSLINE=0
S CODESHET(0)=$E(OLDCODE(0),1,16)_"-",OLDCODE(0)=$E(OLDCODE(0),17,256)
S LINE="" F S LINE=$O(OLDCODE(LINE)) Q:LINE="" F CHAR=1:10 S X=$E(OLDCODE(LINE),CHAR,CHAR+9) Q:X="" D
. ; if x is not 10 characters long, move up data from next line
. I $L(X)<10,$D(OLDCODE(LINE+1)) S %=10-$L(X),X=X_$E(OLDCODE(LINE+1),1,%),OLDCODE(LINE+1)=$E(OLDCODE(LINE+1),%+1,256)
. I X="0000000000" S X=""
. S CODESHET(GECSLINE)=$G(CODESHET(GECSLINE))_X_$S(X["$":"",1:"-")
. I $L(CODESHET(GECSLINE))>GECSEND S CODESHET(GECSLINE+1)=$E(CODESHET(GECSLINE),GECSEND+1,256),CODESHET(GECSLINE)=$E(CODESHET(GECSLINE),1,GECSEND),GECSLINE=GECSLINE+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGECSXBLD 4751 printed Nov 22, 2024@17:06:53 Page 2
GECSXBLD ;WISC/RFJ-map data into template map ;01 Nov 93
+1 ;;2.0;GCS;;MAR 14, 1995
+2 QUIT
+3 ;
+4 ;
MAPDATA(GECSDA) ; map data to template
+1 ; return 1 if code sheet is built, 0 if not built
+2 NEW %,%H,%I,CODESHET,DA,DA1,DATA,DELIMITR,FIELD,GECSDATE,GECSEND,GECSFLAG,GECSLINE,GECSMAP,GECSNOD1,GECSNOD2,GECSOT,GECSTNM,I,N,PIECE,SUB1,SUB2,X,Y
+3 ;
+4 ; keypunched code sheet
+5 KILL CODESHET
+6 IF $PIECE($GET(^GECS(2100,GECSDA,0)),"^",11)="[GECS KEYPUNCH]"
Begin DoDot:1
+7 SET %=0
FOR I=0:1
SET %=$ORDER(^GECS(2100,GECSDA,"KEY",%))
if %=""
QUIT
SET CODESHET(I)=^(%,0)
+8 IF I=0
WRITE !,"NOTHING TO KEYPUNCH."
DO KILLCS^GECSPUR1(GECSDA)
WRITE " << CODE SHEET DELETED >>"
SET GECSFLAG=0
QUIT
+9 SET %=$$SHEET
SET GECSFLAG=1
End DoDot:1
QUIT GECSFLAG
+10 ;
+11 ; fill in fields code sheet
+12 ; set gecsot variable to execute output transform
+13 SET GECSOT=""
+14 ; move code sheet field data into variable data
+15 KILL DATA
+16 SET SUB1=""
FOR
SET SUB1=$ORDER(^GECS(2100,GECSDA,SUB1))
if SUB1=""
QUIT
IF SUB1'="CODE"
if $DATA(^(SUB1))'["0"
SET DATA(SUB1)=^(SUB1)
IF $DATA(^GECS(2100,GECSDA,SUB1,0))
Begin DoDot:1
+17 SET DA1=0
FOR
SET DA1=$ORDER(^GECS(2100,GECSDA,SUB1,DA1))
if 'DA1
QUIT
Begin DoDot:2
+18 SET SUB2=""
FOR
SET SUB2=$ORDER(^GECS(2100,GECSDA,SUB1,DA1,SUB2))
if SUB2=""
QUIT
if $DATA(^GECS(2100,GECSDA,SUB1,DA1,SUB2))
SET DATA(SUB1,DA1,SUB2)=^(SUB2)
End DoDot:2
End DoDot:1
+19 ;
+20 ; get template map
+21 SET GECSTNM=$PIECE(DATA(0),"^",11)
SET GECSTNM=$EXTRACT(GECSTNM,2,$LENGTH(GECSTNM)-1)
IF GECSTNM=""
WRITE !,"CODE SHEET ",$PIECE(DATA(0),"^")," DOES NOT HAVE A TEMPLATE MAP DEFINED."
QUIT 0
+22 SET %=$ORDER(^DIE("B",GECSTNM,0))
IF '%
WRITE !,"INPUT TEMPLATE ",GECSTNM," NOT FOUND."
QUIT 0
+23 DO GETMAP^GECSXMAP(%)
IF '$DATA(GECSMAP)
QUIT 0
+24 ;
+25 SET GECSEND=80
SET DELIMITR=""
+26 ; put code sheet specific code here!!!
+27 IF $PIECE(DATA(0),"^",2)="VOL"
SET GECSEND=81
+28 IF $PIECE(DATA(0),"^",2)="FMS"
SET DELIMITR="^"
SET GECSEND=240
+29 IF $PIECE(DATA(0),"^",2)="FEN"
SET DELIMITR="."
SET GECSEND=240
+30 ; end of code sheet specific code
+31 ;
+32 ; build code sheet with data
+33 ; set da for output transform
+34 SET DA=GECSDA
+35 KILL GECSFLAG
+36 SET (GECSLINE,GECSNOD1)=0
FOR
SET GECSNOD1=$ORDER(GECSMAP(GECSNOD1))
if 'GECSNOD1
QUIT
Begin DoDot:1
+37 ; single field (not multiple)
+38 IF GECSMAP(GECSNOD1)'[","
Begin DoDot:2
+39 FOR PIECE=1:1
SET FIELD=$PIECE(GECSMAP(GECSNOD1),"\",PIECE)
if FIELD=""
QUIT
Begin DoDot:3
+40 SET SUB1=$PIECE(FIELD,";",2)
+41 SET Y=$PIECE($GET(DATA(SUB1)),"^",$PIECE(FIELD,";",3))
+42 DO SETLINE(2100,+FIELD)
End DoDot:3
if $GET(GECSFLAG)
QUIT
End DoDot:2
QUIT
+43 ; multiple field
+44 SET SUB1=$PIECE(GECSMAP(GECSNOD1),",",2)
+45 SET DA1=0
FOR
SET DA1=$ORDER(DATA(SUB1,DA1))
if 'DA1
QUIT
SET GECSNOD2=0
FOR
SET GECSNOD2=$ORDER(GECSMAP(GECSNOD1,GECSNOD2))
if 'GECSNOD2
QUIT
Begin DoDot:2
+46 FOR PIECE=1:1
SET FIELD=$PIECE(GECSMAP(GECSNOD1,GECSNOD2),"\",PIECE)
if FIELD=""
QUIT
Begin DoDot:3
+47 SET SUB2=$PIECE(FIELD,";",2)
+48 SET Y=$PIECE($GET(DATA(SUB1,DA1,SUB2)),"^",$PIECE(FIELD,";",3))
+49 DO SETLINE(+$PIECE(GECSMAP(GECSNOD1),",",3),+FIELD)
End DoDot:3
if $GET(GECSFLAG)
QUIT
End DoDot:2
End DoDot:1
+50 ;
+51 ; put code sheet specific code here (after code sheets have been built)
+52 ; reformat for amis
+53 IF $PIECE(DATA(0),"^",2)="AMS"
DO AMIS
+54 ; end of code sheet specific code
+55 QUIT $$SHEET
+56 ;
+57 ;
SHEET() ; move code sheets to code node
+1 DO NOW^%DTC
SET GECSDATE=%
+2 KILL ^GECS(2100,GECSDA,"CODE")
+3 SET GECSLINE=""
FOR I=1:1
SET GECSLINE=$ORDER(CODESHET(GECSLINE))
if GECSLINE=""
QUIT
SET ^GECS(2100,GECSDA,"CODE",I,0)=CODESHET(GECSLINE)
+4 SET I=I-1
SET ^GECS(2100,GECSDA,"CODE",0)="^^"_I_"^"_I_"^"_$PIECE(GECSDATE,".")_"^^"
+5 DO PRINT^GECSUTIL(GECSDA)
+6 QUIT 1
+7 ;
+8 ;
SETLINE(FILE,FIELD) ; build codeshet array with data in y
+1 IF $DATA(^DD(FILE,+FIELD,2.1))
IF ^(2.1)["GECSOT"
XECUTE ^(2.1)
+2 SET CODESHET(GECSLINE)=$GET(CODESHET(GECSLINE))_$SELECT($GET(CODESHET(GECSLINE))="":"",$GET(CODESHET(GECSLINE))=("LIN^"_$CHAR(126)):"",$PIECE(DATA(0),"^",2)="FEN"&(Y="$"):"",1:DELIMITR)_Y
+3 ; for fms, put each segment on a new line
+4 IF $PIECE(DATA(0),"^",2)="FMS"
IF Y=$CHAR(126)
IF $GET(CODESHET(GECSLINE))'=("LIN^"_$CHAR(126))
SET GECSLINE=GECSLINE+1
+5 IF $LENGTH($GET(CODESHET(GECSLINE)))>GECSEND
SET CODESHET(GECSLINE+1)=$EXTRACT(CODESHET(GECSLINE),GECSEND+1,999)
SET CODESHET(GECSLINE)=$EXTRACT(CODESHET(GECSLINE),1,GECSEND)
SET GECSLINE=GECSLINE+1
+6 IF Y="$"
SET GECSFLAG=1
+7 QUIT
+8 ;
+9 ;
AMIS ; reformat for amis
+1 NEW %,CHAR,LINE,OLDCODE,X
+2 ; move code sheet (in codeshet) to temp variable for processing
+3 KILL OLDCODE
SET %=""
FOR
SET %=$ORDER(CODESHET(%))
if %=""
QUIT
SET OLDCODE(%)=CODESHET(%)
+4 KILL CODESHET
SET GECSLINE=0
+5 SET CODESHET(0)=$EXTRACT(OLDCODE(0),1,16)_"-"
SET OLDCODE(0)=$EXTRACT(OLDCODE(0),17,256)
+6 SET LINE=""
FOR
SET LINE=$ORDER(OLDCODE(LINE))
if LINE=""
QUIT
FOR CHAR=1:10
SET X=$EXTRACT(OLDCODE(LINE),CHAR,CHAR+9)
if X=""
QUIT
Begin DoDot:1
+7 ; if x is not 10 characters long, move up data from next line
+8 IF $LENGTH(X)<10
IF $DATA(OLDCODE(LINE+1))
SET %=10-$LENGTH(X)
SET X=X_$EXTRACT(OLDCODE(LINE+1),1,%)
SET OLDCODE(LINE+1)=$EXTRACT(OLDCODE(LINE+1),%+1,256)
+9 IF X="0000000000"
SET X=""
+10 SET CODESHET(GECSLINE)=$GET(CODESHET(GECSLINE))_X_$SELECT(X["$":"",1:"-")
+11 IF $LENGTH(CODESHET(GECSLINE))>GECSEND
SET CODESHET(GECSLINE+1)=$EXTRACT(CODESHET(GECSLINE),GECSEND+1,256)
SET CODESHET(GECSLINE)=$EXTRACT(CODESHET(GECSLINE),1,GECSEND)
SET GECSLINE=GECSLINE+1
End DoDot:1
+12 QUIT
