%AUFLD ;PRINT IHS DICTIONARY FIELDS [ 06/16/89 1:15 PM ]
;IHS-OKLA CITY AREA OFFICE-LMD
;CHANGED LINE L6 TO COMMENT TO ALLOW REQUEST FOR NEXT FILE
;CHANGED LINE END TO GOTO S1. THIS ALLOWS CLOSE OF DEVICE
;SO THAT SLAVE PRINTERS WILL FUNCTION TJF 5/18/88
;LINE 'END' TO NOT WRITE @IOF IF OUTPUT TO TERMINAL; RPMS/GTH; 20DEC88
;CHANGED 3 OCCURRENCES OF X]"@" TO X'=+X MFD 6/8/89
;MODIFIED (COMPRESSED) HEADER PRINTING MFD 6/16/89
S1 W !! S DIC="^DIC(",DIC(0)="QAZEM" D ^DIC G:Y<0 QUIT S (DIC,MG("DIC"))=+Y
L1 G QUE
W !! S IOP="Q" D ^%ZIS
L2 S PG=0 K MGIO S:$D(AU("PRINT")) MGIO=+$I S IOP=IO D ^%ZIS U IO D HEADING
L4 W ! S (D,SK1,SK2,SK3)=0 K MG("PAT") S:DIC=9000001 MG("PAT")=""
L5 S D=$O(^DD(DIC,D)) G L6:D'=+D S MF=($P(^DD(DIC,D,0),"^",2)) G L7:+MF>0 S Q=$P(^DD(DIC,D,0),"^",4),Q1=$P(Q,";",1),Q2=$P(Q,";",2) W:Q1'=SK1 ! S SK1=Q1 W ?5,D,?15,$P(^DD(DIC,D,0),"^",1)
I $D(^DD(DIC,D,9.01))&$D(MG("PAT")) I $P(^DD(DIC,D,9.01),"^",1)=2 W "/",$P($P(^DD(DIC,D,9.01),"^",2),";",1)
L5A G L5B:Q1=" " W ?45,"DFN,",Q1,?61,Q2,?74,$S(MF["D":"D",MF["P":"P",MF["F":"F",MF["S":"S",MF["W":"W",MF["N":"N",1:"?") G L5C
L5B W ?45,"COMP"
L5C W ! D HEADING:$Y>(IOSL-3) G S1:Y="^",L5
L6 ;I $D(MGIO) I MGIO=IO K MG,MGIO G S1
END W:IOSL>24 @IOF X ^%ZIS("C") K MG,MGIO G S1
QUIT K %DT,AU,C,D,DD,DDD,DDDD,DIC,EE,EEE,EEEE,G,GEE,GG,GGG,HR,I,IO,IOBS,IOF,IOM,ION,IOP,IOPAR,IOS,IOSL,IOST,IOT,MF,MF,MG,MGIO,MIN,MMF,MMMF,PG,POP,Q,Q1,Q2,SK1,SK2,SK3,TITLE,TM,TME,U,USER,X,Y
Q
L7 W !,?5,D,?15,$P(^DD(DIC,D,0),"^",1)," (",+MF,")",! S DD=0,GG=$P(($P(^DD(DIC,D,0),"^",4)),";",1)
L8 S DD=$O(^DD(+MF,DD)) G L10:DD'=+DD S MMF=$P(^DD(+MF,DD,0),"^",2) G L20:+MMF>0 S G=$P(^DD(+MF,DD,0),"^",4),DDD=$P(G,";",1),DDDD=$P(G,";",2)
L9 W:SK2'=DDD ! S SK2=DDD W ?7,DD,?17,$P(^DD(+MF,DD,0),"^",1) W:DDD=" " ?47,"COMP" G L9A:DDD=" "
W ?47,"DFN,",GG,",I,",DDD,?63,DDDD,?76,$S(MMF["D":"D",MMF["P":"P",MMF["F":"F",MMF["S":"S",MMF["W":"W",MMF["N":"N",1:"?")
L9A W ! I $Y>(IOSL-3) D HEADING G:Y="^" S1 W ?5,D,?15,$P(^DD(DIC,D,0),"^",1)," (cont.)",!
L9B G L8
L10 G L5
L20 W !,?7,DD,?17,$P(^DD(+MF,DD,0),"^",1)," (",+MMF,")",! S EE=0,GGG=$P(($P(^DD(+MF,DD,0),"^",4)),";",1)
L21 S EE=$O(^DD(+MMF,EE)) G L25:EE'=+EE S MMMF=$P(^DD(+MMF,EE,0),"^",2),GEE=$P(^DD(+MMF,EE,0),"^",4),EEE=$P(GEE,";",1),EEEE=$P(GEE,";",2)
L22 W:SK3'=EEE ! S SK3=EEE W ?9,EE,?19,$P(^DD(+MMF,EE,0),"^",1) W:EEE=" " ?49,"COMP" G L23:EEE=" " W:EEEE=0 " (",+$P(^DD(+MMF,EE,0),"^",2),")",?49,"MUL" G L23:EEEE=0
W ?49,"DFN,",GG,",1,",GGG,",I,",EEE,?67,EEEE,?78,$S(MMMF["D":"D",MMMF["P":"P",MMMF["F":"F",MMMF["S":"S",MMMF["W":"W",MMMF["N":"N",1:"?")
L23 W ! I $Y>(IOSL-3) D HEADING G:Y="^" S1 W ?5,D,?15,$P(^DD(DIC,D,0),"^",1)," (cont.)",!,?7,DD,?17,$P(^DD(+MF,DD,0),"^",1)," (cont.)",!
L24 G L21
L25 G L8
HEADING I PG'=0,IOSL=24 R !,"Press RETURN...",Y:999 Q:Y="^"
I PG'=0 S PG=PG+1 W # G H2
S PG=PG+1,TITLE="I.H.S. DICTIONARY FIELDS",TM=$P($H,",",2),HR=TM\3600,MIN=TM#3600\60 S:MIN<10 MIN="0"_MIN S TME=HR_":"_MIN,USER=""
W #,!,TME,?80-$L(TITLE)\2,TITLE,!,?80-$L(^DD("SITE"))\2,^DD("SITE"),!
UCI X ^%ZOSF("UCI") S MG("UCI")="UCI: "_$P(Y,",",1) W ?80-$L(MG("UCI"))\2,MG("UCI")
I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
S Y=DT X ^DD("DD") W !,?80-$L("as of "_Y)\2,"as of ",Y,!!
H2 W ?80-$L("FILE: "_$P(^DIC(DIC,0),"^",1))\2,"FILE: ",$P(^DIC(DIC,0),"^",1),!,?80-$L("GLOBAL: "_^DIC(DIC,0,"GL"))\2,"GLOBAL: ",^DIC(DIC,0,"GL"),?70,"page ",PG,!,?80-$L("FILE #: "_DIC)\2,"FILE #: ",DIC,!
H3 W ?5,"FIELD #",?15,"FIELD NAME",?43,"SUBSCRIPT",?60,"PIECE #",?72,"TYPE",!,"=====1 2 3" F I=1:1:69 W "="
W ! Q
PRQ S DIC=^%ZTSK(ZTSK,"DIC")
PRQ1 S:$D(^%ZTSK(ZTSK,"SITE")) DUZ(2)=^%ZTSK(ZTSK,"SITE") S U="^" K ^%ZTSK(ZTSK) G L2
QUE S:'$D(DUZ) DUZ=0 D ^%AUQUE G L2:$D(AU("PRINT")),QUIT:'$D(AU("QUE"))
QUE1 S ^%ZTSK(ZTSK,0)="PRQ^%AUFLD"_^%ZTSK(ZTSK,0),^("DIC")=MG("DIC")
QUEEND K ZTSK G S1
%AUFLD ;PRINT IHS DICTIONARY FIELDS [ 06/16/89 1:15 PM ]
+1 ;IHS-OKLA CITY AREA OFFICE-LMD
+2 ;CHANGED LINE L6 TO COMMENT TO ALLOW REQUEST FOR NEXT FILE
+3 ;CHANGED LINE END TO GOTO S1. THIS ALLOWS CLOSE OF DEVICE
+4 ;SO THAT SLAVE PRINTERS WILL FUNCTION TJF 5/18/88
+5 ;LINE 'END' TO NOT WRITE @IOF IF OUTPUT TO TERMINAL; RPMS/GTH; 20DEC88
+6 ;CHANGED 3 OCCURRENCES OF X]"@" TO X'=+X MFD 6/8/89
+7 ;MODIFIED (COMPRESSED) HEADER PRINTING MFD 6/16/89
S1 WRITE !!
SET DIC="^DIC("
SET DIC(0)="QAZEM"
DO ^DIC
IF Y<0
GOTO QUIT
SET (DIC,MG("DIC"))=+Y
L1 GOTO QUE
+1 WRITE !!
SET IOP="Q"
DO ^%ZIS
L2 SET PG=0
KILL MGIO
IF $DATA(AU("PRINT"))
SET MGIO=+$IO
SET IOP=IO
DO ^%ZIS
USE IO
DO HEADING
L4 WRITE !
SET (D,SK1,SK2,SK3)=0
KILL MG("PAT")
IF DIC=9000001
SET MG("PAT")=""
L5 SET D=$ORDER(^DD(DIC,D))
IF D'=+D
GOTO L6
SET MF=($PIECE(^DD(DIC,D,0),"^",2))
IF +MF>0
GOTO L7
SET Q=$PIECE(^DD(DIC,D,0),"^",4)
SET Q1=$PIECE(Q,";",1)
SET Q2=$PIECE(Q,";",2)
IF Q1'=SK1
WRITE !
SET SK1=Q1
WRITE ?5,D,?15,$PIECE(^DD(DIC,D,0),"^",1)
+1 IF $DATA(^DD(DIC,D,9.01))&$DATA(MG("PAT"))
IF $PIECE(^DD(DIC,D,9.01),"^",1)=2
WRITE "/",$PIECE($PIECE(^DD(DIC,D,9.01),"^",2),";",1)
L5A IF Q1=" "
GOTO L5B
WRITE ?45,"DFN,",Q1,?61,Q2,?74,$SELECT(MF["D":"D",MF["P":"P",MF["F":"F",MF["S":"S",MF["W":"W",MF["N":"N",1:"?")
GOTO L5C
L5B WRITE ?45,"COMP"
L5C WRITE !
IF $Y>(IOSL-3)
DO HEADING
IF Y="^"
GOTO S1
GOTO L5
L6 ;I $D(MGIO) I MGIO=IO K MG,MGIO G S1
END IF IOSL>24
WRITE @IOF
XECUTE ^%ZIS("C")
KILL MG,MGIO
GOTO S1
QUIT KILL %DT,AU,C,D,DD,DDD,DDDD,DIC,EE,EEE,EEEE,G,GEE,GG,GGG,HR,I,IO,IOBS,IOF,IOM,ION,IOP,IOPAR,IOS,IOSL,IOST,IOT,MF,MF,MG,MGIO,MIN,MMF,MMMF,PG,POP,Q,Q1,Q2,SK1,SK2,SK3,TITLE,TM,TME,U,USER,X,Y
+1 QUIT
L7 WRITE !,?5,D,?15,$PIECE(^DD(DIC,D,0),"^",1)," (",+MF,")",!
SET DD=0
SET GG=$PIECE(($PIECE(^DD(DIC,D,0),"^",4)),";",1)
L8 SET DD=$ORDER(^DD(+MF,DD))
IF DD'=+DD
GOTO L10
SET MMF=$PIECE(^DD(+MF,DD,0),"^",2)
IF +MMF>0
GOTO L20
SET G=$PIECE(^DD(+MF,DD,0),"^",4)
SET DDD=$PIECE(G,";",1)
SET DDDD=$PIECE(G,";",2)
L9 IF SK2'=DDD
WRITE !
SET SK2=DDD
WRITE ?7,DD,?17,$PIECE(^DD(+MF,DD,0),"^",1)
IF DDD=" "
WRITE ?47,"COMP"
IF DDD=" "
GOTO L9A
+1 WRITE ?47,"DFN,",GG,",I,",DDD,?63,DDDD,?76,$SELECT(MMF["D":"D",MMF["P":"P",MMF["F":"F",MMF["S":"S",MMF["W":"W",MMF["N":"N",1:"?")
L9A WRITE !
IF $Y>(IOSL-3)
DO HEADING
IF Y="^"
GOTO S1
WRITE ?5,D,?15,$PIECE(^DD(DIC,D,0),"^",1)," (cont.)",!
L9B GOTO L8
L10 GOTO L5
L20 WRITE !,?7,DD,?17,$PIECE(^DD(+MF,DD,0),"^",1)," (",+MMF,")",!
SET EE=0
SET GGG=$PIECE(($PIECE(^DD(+MF,DD,0),"^",4)),";",1)
L21 SET EE=$ORDER(^DD(+MMF,EE))
IF EE'=+EE
GOTO L25
SET MMMF=$PIECE(^DD(+MMF,EE,0),"^",2)
SET GEE=$PIECE(^DD(+MMF,EE,0),"^",4)
SET EEE=$PIECE(GEE,";",1)
SET EEEE=$PIECE(GEE,";",2)
L22 IF SK3'=EEE
WRITE !
SET SK3=EEE
WRITE ?9,EE,?19,$PIECE(^DD(+MMF,EE,0),"^",1)
IF EEE=" "
WRITE ?49,"COMP"
IF EEE=" "
GOTO L23
IF EEEE=0
WRITE " (",+$PIECE(^DD(+MMF,EE,0),"^",2),")",?49,"MUL"
IF EEEE=0
GOTO L23
+1 WRITE ?49,"DFN,",GG,",1,",GGG,",I,",EEE,?67,EEEE,?78,$SELECT(MMMF["D":"D",MMMF["P":"P",MMMF["F":"F",MMMF["S":"S",MMMF["W":"W",MMMF["N":"N",1:"?")
L23 WRITE !
IF $Y>(IOSL-3)
DO HEADING
IF Y="^"
GOTO S1
WRITE ?5,D,?15,$PIECE(^DD(DIC,D,0),"^",1)," (cont.)",!,?7,DD,?17,$PIECE(^DD(+MF,DD,0),"^",1)," (cont.)",!
L24 GOTO L21
L25 GOTO L8
HEADING IF PG'=0
IF IOSL=24
READ !,"Press RETURN...",Y:999
IF Y="^"
QUIT
+1 IF PG'=0
SET PG=PG+1
WRITE #
GOTO H2
+2 SET PG=PG+1
SET TITLE="I.H.S. DICTIONARY FIELDS"
SET TM=$PIECE($HOROLOG,",",2)
SET HR=TM\3600
SET MIN=TM#3600\60
IF MIN<10
SET MIN="0"_MIN
SET TME=HR_":"_MIN
SET USER=""
+3 WRITE #,!,TME,?80-$LENGTH(TITLE)\2,TITLE,!,?80-$LENGTH(^DD("SITE"))\2,^DD("SITE"),!
UCI XECUTE ^%ZOSF("UCI")
SET MG("UCI")="UCI: "_$PIECE(Y,",",1)
WRITE ?80-$LENGTH(MG("UCI"))\2,MG("UCI")
+1 IF '$DATA(DT)
SET %DT=""
SET X="T"
DO ^%DT
SET DT=Y
+2 SET Y=DT
XECUTE ^DD("DD")
WRITE !,?80-$LENGTH("as of "_Y)\2,"as of ",Y,!!
H2 WRITE ?80-$LENGTH("FILE: "_$PIECE(^DIC(DIC,0),"^",1))\2,"FILE: ",$PIECE(^DIC(DIC,0),"^",1),!,?80-$LENGTH("GLOBAL: "_^DIC(DIC,0,"GL"))\2,"GLOBAL: ",^DIC(DIC,0,"GL"),?70,"page ",PG,!,?80-$LENGTH("FILE #: "_DIC)\2,"FILE #: ",DIC,!
H3 WRITE ?5,"FIELD #",?15,"FIELD NAME",?43,"SUBSCRIPT",?60,"PIECE #",?72,"TYPE",!,"=====1 2 3"
FOR I=1:1:69
WRITE "="
+1 WRITE !
QUIT
PRQ SET DIC=^%ZTSK(ZTSK,"DIC")
PRQ1 IF $DATA(^%ZTSK(ZTSK,"SITE"))
SET DUZ(2)=^%ZTSK(ZTSK,"SITE")
SET U="^"
KILL ^%ZTSK(ZTSK)
GOTO L2
QUE IF '$DATA(DUZ)
SET DUZ=0
DO ^%AUQUE
IF $DATA(AU("PRINT"))
GOTO L2
IF '$DATA(AU("QUE"))
GOTO QUIT
QUE1 SET ^%ZTSK(ZTSK,0)="PRQ^%AUFLD"_^%ZTSK(ZTSK,0)
SET ^("DIC")=MG("DIC")
QUEEND KILL ZTSK
GOTO S1
