- %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
