LRINTEGL.m

LRINTEGL ;SLC/FHS - LOAD INTERGRITY FILE 69.91 ; 4/7/89  00:05 ;

 ;;V~5.0~;LAB;**24**;02/27/90 17:09

LOAD ;load routines into ^LAB(69.91,VNODE

 D STOP S LOAD=1 D VER^LRINTEG G STOP:Y<0

 S %ZIS="Q" D ^%ZIS G STOP:POP I $D(IO("Q")) S ZTRTN="QUE^LRINTEGL",ZTDESC="Loading LR INTEGRITY file #69.91 ",ZTIO=ION F I="LOAD","VNODE","VER","VERDAT" S ZTSAVE(I)=""

 I $D(IO("Q")) D ^%ZTLOAD G STOP

 U IO

QUE ;

 S U="^",XLOAD=^%ZOSF("LOAD"),DIF="^UTILITY(""LRINTEG"""_","_$J_",",LROSYS=$S(^%ZOSF("OS")["M/VX"!(^%ZOSF("OS")["M/11"):"^ROUTINE(ROU)",1:"^ (ROU)")

 S DA(1)=VNODE,DIE="^LAB(69.91,"_DA(1)_",""ROU"",",DIC(0)="L" S:'$D(@(DIE_"0)")) @(DIE_"0)")="^69.911^^" S DA=$S($D(@(DIE_"0)")):+$P(^(0),U,3)+1,1:1) S CNT=$S(DA=1:1,1:+$P(@(DIE_"0)"),U,4)+1)

 S (DIC(0),ROU)="L" F CNT=CNT:1 S ROU=$O(@LROSYS) Q:$E(ROU,1)'="L"  W !,ROU D GLB

 S $P(@(DIE_"0)"),U,3)=DA,CNT=CNT-1,$P(^(0),U,4)=CNT W !!,"TOTAL = ",CNT,@IOF K:$D(ZTSK) ^%ZSTK(ZTSK),ZTSK G STOP

GLB ; Stuff new routine in to global using auto load [if it doesn,t already exist] in global

 K ^UTILITY("LRINTEG",$J) S X=ROU,XCNP=0 X XLOAD I '$D(^UTILITY("LRINTEG",$J,2,0)) S CNT=CNT-1 W !?10,"ONLY ONE LINE IN ROUTINE ",! Q

 I ^UTILITY("LRINTEG",$J,2,0)'[";;V~" D ER2 S CNT=CNT-1 Q

 I ^UTILITY("LRINTEG",$J,2,0)'[VER D ER2 S CNT=CNT-1 Q

 I $D(@(DIE_"""B"","""_ROU_""")")) S CNT=CNT-1 Q

GLB1 I $D(@(DIE_DA_",0)")) S DA=DA+1 G GLB1

 K ^UTILITY("LRINTEG",$J) S DR=".01///^S X="""_ROU_""";" D ^DIE

 S $P(@(DIE_"0)"),U,3)=DA,$P(^(0),U,4)=CNT Q

STOP ; clean-up

 X ^%ZIS("C") K DIC,DIE,%ZIS

 K A,BIT,CNT,DIF,ER,I,II,IX,L,LN,LOAD,LROSYS,NT,ROU,SIZE,VER,VERDDT,VNODE,XBIT,XCMP,XCNP,XLOAD,XSIZE,XTEST,YBIT,^UTILITY("LRINTEG",$J) Q

ER2 ; Error msg when the version being loaded do not match the version selected for auto loading

 W !?10,ROU," is version ",$S($L($P(^UTILITY("LRINTEG",$J,2,0),"~",2)):$P(^(0),"~",2),1:"Unknown ")," NOT LOADED",*7,! Q

LRINTEGL  ;SLC/FHS - LOAD INTERGRITY FILE 69.91 ; 4/7/89  00:05 ;

 +1       ;;V~5.0~;LAB;**24**;02/27/90 17:09

LOAD      ;load routines into ^LAB(69.91,VNODE

 +1        DO STOP

           SET LOAD=1

           DO VER^LRINTEG

           IF Y<0

               GOTO STOP

 +2        SET %ZIS="Q"

           DO ^%ZIS

           IF POP

               GOTO STOP

           IF $DATA(IO("Q"))

               SET ZTRTN="QUE^LRINTEGL"

               SET ZTDESC="Loading LR INTEGRITY file #69.91 "

               SET ZTIO=ION

               FOR I="LOAD","VNODE","VER","VERDAT"

                   SET ZTSAVE(I)=""

 +3        IF $DATA(IO("Q"))

               DO ^%ZTLOAD

               GOTO STOP

 +4        USE IO

QUE       ;

 +1        SET U="^"

           SET XLOAD=^%ZOSF("LOAD")

           SET DIF="^UTILITY(""LRINTEG"""_","_$JOB_","

           SET LROSYS=$SELECT(^%ZOSF("OS")["M/VX"!(^%ZOSF("OS")["M/11"):"^ROUTINE(ROU)",1:"^ (ROU)")

 +2        SET DA(1)=VNODE

           SET DIE="^LAB(69.91,"_DA(1)_",""ROU"","

           SET DIC(0)="L"

           IF '$DATA(@(DIE_"0)"))

               SET @(DIE_"0)")="^69.911^^"

           SET DA=$SELECT($DATA(@(DIE_"0)")):+$PIECE(^(0),U,3)+1,1:1)

           SET CNT=$SELECT(DA=1:1,1:+$PIECE(@(DIE_"0)"),U,4)+1)

 +3        SET (DIC(0),ROU)="L"

           FOR CNT=CNT:1

               SET ROU=$ORDER(@LROSYS)

               IF $EXTRACT(ROU,1)'="L"

                   QUIT 

               WRITE !,ROU

               DO GLB

 +4        SET $PIECE(@(DIE_"0)"),U,3)=DA

           SET CNT=CNT-1

           SET $PIECE(^(0),U,4)=CNT

           WRITE !!,"TOTAL = ",CNT,@IOF

           IF $DATA(ZTSK)

               KILL ^%ZSTK(ZTSK),ZTSK

           GOTO STOP

GLB       ; Stuff new routine in to global using auto load [if it doesn,t already exist] in global

 +1        KILL ^UTILITY("LRINTEG",$JOB)

           SET X=ROU

           SET XCNP=0

           XECUTE XLOAD

           IF '$DATA(^UTILITY("LRINTEG",$JOB,2,0))

               SET CNT=CNT-1

               WRITE !?10,"ONLY ONE LINE IN ROUTINE ",!

               QUIT 

 +2        IF ^UTILITY("LRINTEG",$JOB,2,0)'[";;V~"

               DO ER2

               SET CNT=CNT-1

               QUIT 

 +3        IF ^UTILITY("LRINTEG",$JOB,2,0)'[VER

               DO ER2

               SET CNT=CNT-1

               QUIT 

 +4        IF $DATA(@(DIE_"""B"","""_ROU_""")"))

               SET CNT=CNT-1

               QUIT 

GLB1       IF $DATA(@(DIE_DA_",0)"))

               SET DA=DA+1

               GOTO GLB1

 +1        KILL ^UTILITY("LRINTEG",$JOB)

           SET DR=".01///^S X="""_ROU_""";"

           DO ^DIE

 +2        SET $PIECE(@(DIE_"0)"),U,3)=DA

           SET $PIECE(^(0),U,4)=CNT

           QUIT 

STOP      ; clean-up

 +1        XECUTE ^%ZIS("C")

           KILL DIC,DIE,%ZIS

 +2        KILL A,BIT,CNT,DIF,ER,I,II,IX,L,LN,LOAD,LROSYS,NT,ROU,SIZE,VER,VERDDT,VNODE,XBIT,XCMP,XCNP,XLOAD,XSIZE,XTEST,YBIT,^UTILITY("LRINTEG",$JOB)

           QUIT 

ER2       ; Error msg when the version being loaded do not match the version selected for auto loading

 +1        WRITE !?10,ROU," is version ",$SELECT($LENGTH($PIECE(^UTILITY("LRINTEG",$JOB,2,0),"~",2)):$PIECE(^(0),"~",2),1:"Unknown ")," NOT LOADED",*7,!

           QUIT