Routine: LR302A

LR302A ;DALOI/FHS - LR*5.2*302 SAVE POINTER VALUES PREINSTAL;29-APR-2004

 ;;5.2;LR;**302,1022**;September 20, 2007

 ; This VA Patch is being included as part of IHS Lab Patch 1022

 ;Saves the pointer values for the globals being deleted. The post

 ;routine will restore the cooresponding pointers to the installed file.

EN ;

 I $G(^XTMP("LR302",1,0)) D  Q  ;Indicates the pointers have already been saved.

 . D BMES^LR302("Historical data previously saved")

 I '$G(LRDBUG) K ^XTMP("LR302")

 S ^XTMP("LR302",0)=$$FMADD^XLFDT(DT,90)_U_DT_U_"LR302 PreInstall Historical Resolved Data"

 N ERR,FILE,FLD,FLD2,FLD9,FLDP,FLDV,IEN,IEN2,LNC,LRD,LRI,LRI2,LRI3,OUT

SAVE642 ;Save a copy ^LAB(64.2 for checking later

 . N LAST

 . Q:$G(^XTMP("LRNLT642",.01))

 . K ^XTMP("LRNLT642")

 . S LAST=$O(^LAB(64.2,99999),-1)

 . S ^XTMP("LRNLT642",.01)=LAST

 . S ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($H+90,1)_U_DT_U_"LAB(64.2 Save"

 . M ^XTMP("LRNLT642",1)=^LAB(64.2)

60 ;Save values for file # 60.01,95.3

 D PRT(60)

 K ^XTMP("LR302",60.01),IEN,IEN2,FLD

 S FLD=95.3

 S IEN=0 F  S IEN=$O(^LAB(60,IEN)) Q:IEN<1  D

 . S IEN2=0 F  S IEN2=$O(^LAB(60,IEN,1,IEN2)) Q:IEN2<1  D

 . . D SAVE(60.01,IEN2_","_IEN_",",FLD,95.3)

 Q:$G(LRDBUG)

61 ;Save values from ^LAB(61  fields .09,.0961

 D PRT(61)

 K ^XTMP("LR302",61),OUT,ERR

 S FLD=".09;.0961"

 S LRI=0 F  S LRI=$O(^LAB(61,LRI)) Q:LRI<1  D

 . D SAVE(61,LRI_",",FLD,"")

 Q:$G(LRDBUG)

6205 ;Save values from ^LAB(62.05 field 4

 D PRT(62.05)

 K ^XTMP("LR302",62.05),OUT,ERR

 S FLD=4,LRI=0

 F  S LRI=$O(^LAB(62.05,LRI)) Q:LRI<1  D

 . D SAVE(62.05,LRI_",",FLD,"")

 Q:$G(LRDBUG)

624 ;Extract data from ^LAB(62.4, field .14

 D PRT(62.4)

 K FLD,IEN,^XTMP("LR302",62.4)

 S FLD=.14

 S IEN=0 F  S IEN=$O(^LAB(62.4,IEN)) Q:IEN<1  D

 . D SAVE(62.4,IEN_",",FLD,"")

 Q:$G(LRDBUG)

628 ;Save values from ^LAHM(62.8  fields 1.13,1.23,2.13,2.23,2.33

 D PRT(62.8)

 K OUT,ERR,FLD,FLD9,VAL,FLDV,IENX

 K ^XTMP("LR302",62.801)

 S FLD9="1.14;1.24;2.14;2.24;2.34",IEN=0

 S FLD="1.13;1.23;2.13;2.23;2.33"

 F  S IEN=$O(^LAHM(62.8,IEN)) Q:IEN<1  D

 . S IEN2=0 F  S IEN2=$O(^LAHM(62.8,IEN,10,IEN2)) Q:IEN2<1  D

 . . S IENX=IEN2_","_IEN_"," D SAVE(62.801,IENX,FLD,"")

 . . D SAVE(62.801,IENX,FLD9,95.3)

 Q:$G(LRDBUG)

6285 ;Extract data from ^LAHM(62.85  field .05

 D PRT(62.85)

 K IEN,FLD,OUT,ERR

 K ^XTMP("LR302",62.85)

 S IEN=0,FLD=.05 F  S IEN=$O(^LAHM(62.85,IEN)) Q:IEN<1  D

 . D SAVE(62.85,IEN_",",FLD,"")

 Q:$G(LRDBUG)

629 ; Extract data from ^LAHM(62.9,,60 fields 1.15,1.25,2.15,2.25,2.35

 D PRT(62.9)

 K IEN,IEN2,IENX,FLD,FLD9,OUT,ERR

 K ^XTMP("LR302",62.9001)

 S FLD="1.15;1.25;2.15;2.25;2.35"

 S FLD9="1.16;1.26;2.16;2.26;2.36",IEN=0

 F  S IEN=$O(^LAHM(62.9,IEN)) Q:IEN<1  D

 . S IEN2=0  F  S IEN2=$O(^LAHM(62.9,IEN,60,IEN2)) Q:IEN2<1  D

 . . S IENX=IEN2_","_IEN_"," D SAVE(62.9001,IENX,FLD,"")

 . . D SAVE(62.9001,IENX,FLD9,95.3)

 Q:$G(LRDBUG)

 G 642

6402 ;Save values from ^LAM(IEN,5,IEN2,1 fields

 N FLD2,OUT,ERR,LRD,IEN2,LRI2,LRI3

 S FLD2=".01;1"

 S LRI2=0 F  S LRI2=$O(^LAM(LRI,5,LRI2)) Q:LRI2<1  D

 . S LRI3=0 F  S LRI3=$O(^LAM(LRI,5,LRI2,1,LRI3)) Q:LRI3<1  D

 . . S IEN2=LRI3_","_LRI2_","_LRI_","

 . . D SAVE(64.02,IEN2,4,95.3)

 . . D SAVE(64.02,IEN2,FLD2,"")

642 ;Save values from ^LAB(64.2  1,4,7,8,9,15

 D PRT(64.2)

 K FLD,IEN,^XTMP("LR302",64.2)

 S FLD="1;4;7;8;9;15"

 S IEN=0 F  S IEN=$O(^LAB(64.2,IEN)) Q:IEN<1  D

 . D SAVE(64.2,IEN_",",FLD,"")

 Q:$G(LRDBUG)

682 ;Extract date for ^LRO(68.2,  field .14

 D PRT(68.2)

 K FLD,IEN,^XTMP("LR302",68.2)

 S FLD=.14

 S IEN=0 F  S IEN=$O(^LRO(68.2,IEN)) Q:IEN<1  D

 . D SAVE(68.2,IEN_",",FLD,"")

 Q:$G(LRDBUG)

696 ;

 D PRT(69.6)

 K FLD,FLD2,IEN,IEN2

 K ^XTMP("LR302",69.6),^(69.64)

 S FLD=6,FLD2=5,IEN=0

 F  S IEN=$O(^LRO(69.6,IEN)) Q:IEN<1  D

 . D SAVE(69.6,IEN_",",FLD,"")

 . S IEN2=0 F  S IEN2=$O(^LRO(69.6,IEN,2,IEN2)) Q:IEN2<1  D

 . . D SAVE(69.64,IEN2_","_IEN_",",FLD2,"")

 Q:$G(LRDBUG)

 S ^XTMP("LR302",1,0)=$$NOW^XLFDT_U_"Historical pointers saved"

SAVE(FILE,IENX,FLD,LNC) ;Save Data  (FILE #,IEN,Fields,95.3)

 K OUT,ERR,VAL,FLDP,FLDV

 I $G(IEN),(IEN#400=0) W "."

 D GETS^DIQ(FILE,IENX,FLD,"E","OUT","ERR")

 F FLDP=1:1 S FLDV=$P(FLD,";",FLDP) Q:'$L(FLDV)  D

 . S VAL=$G(OUT(FILE,IENX,FLDV,"E")) I $L(VAL) D

 . . S ^XTMP("LR302",FILE,IENX,FLDV)=$S(LNC=95.3:+VAL,1:VAL)

PRT(FILE) ;Display file name

 D BMES^LR302("Saving File #"_FILE_" data.")

W !

LR302A    ;DALOI/FHS - LR*5.2*302 SAVE POINTER VALUES PREINSTAL;29-APR-2004

 +1       ;;5.2;LR;**302,1022**;September 20, 2007

 +2       ;

 +3       ; This VA Patch is being included as part of IHS Lab Patch 1022

 +4       ;

 +5       ;Saves the pointer values for the globals being deleted. The post

 +6       ;routine will restore the cooresponding pointers to the installed file.

EN        ;

 +1       ;Indicates the pointers have already been saved.

           IF $GET(^XTMP("LR302",1,0))

               Begin DoDot:1

 +2                DO BMES^LR302("Historical data previously saved")

               End DoDot:1

               QUIT

 +3       ;

 +4        IF '$GET(LRDBUG)

               KILL ^XTMP("LR302")

 +5        SET ^XTMP("LR302",0)=$$FMADD^XLFDT(DT,90)_U_DT_U_"LR302 PreInstall Historical Resolved Data"

 +6       ;

 +7        NEW ERR,FILE,FLD,FLD2,FLD9,FLDP,FLDV,IEN,IEN2,LNC,LRD,LRI,LRI2,LRI3,OUT

SAVE642   ;Save a copy ^LAB(64.2 for checking later

 +1        Begin DoDot:1

 +2            NEW LAST

 +3            IF $GET(^XTMP("LRNLT642",.01))

                   QUIT

 +4            KILL ^XTMP("LRNLT642")

 +5            SET LAST=$ORDER(^LAB(64.2,99999),-1)

 +6            SET ^XTMP("LRNLT642",.01)=LAST

 +7            SET ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($HOROLOG+90,1)_U_DT_U_"LAB(64.2 Save"

 +8            MERGE ^XTMP("LRNLT642",1)=^LAB(64.2)

           End DoDot:1

60        ;Save values for file # 60.01,95.3

 +1        DO PRT(60)

 +2        KILL ^XTMP("LR302",60.01),IEN,IEN2,FLD

 +3        SET FLD=95.3

 +4        SET IEN=0

FOR

               SET IEN=$ORDER(^LAB(60,IEN))

               IF IEN<1

                   QUIT

               Begin DoDot:1

 +5                SET IEN2=0

FOR

                       SET IEN2=$ORDER(^LAB(60,IEN,1,IEN2))

                       IF IEN2<1

                           QUIT

                       Begin DoDot:2

 +6                        DO SAVE(60.01,IEN2_","_IEN_",",FLD,95.3)

                       End DoDot:2

               End DoDot:1

 +7        IF $GET(LRDBUG)

               QUIT

61        ;Save values from ^LAB(61  fields .09,.0961

 +1        DO PRT(61)

 +2        KILL ^XTMP("LR302",61),OUT,ERR

 +3        SET FLD=".09;.0961"

 +4        SET LRI=0

FOR

               SET LRI=$ORDER(^LAB(61,LRI))

               IF LRI<1

                   QUIT

               Begin DoDot:1

 +5                DO SAVE(61,LRI_",",FLD,"")

               End DoDot:1

 +6        IF $GET(LRDBUG)

               QUIT

6205      ;Save values from ^LAB(62.05 field 4

 +1        DO PRT(62.05)

 +2        KILL ^XTMP("LR302",62.05),OUT,ERR

 +3        SET FLD=4

           SET LRI=0

 +4        FOR

               SET LRI=$ORDER(^LAB(62.05,LRI))

               IF LRI<1

                   QUIT

               Begin DoDot:1

 +5                DO SAVE(62.05,LRI_",",FLD,"")

               End DoDot:1

 +6        IF $GET(LRDBUG)

               QUIT

624       ;Extract data from ^LAB(62.4, field .14

 +1        DO PRT(62.4)

 +2        KILL FLD,IEN,^XTMP("LR302",62.4)

 +3        SET FLD=.14

 +4        SET IEN=0

FOR

               SET IEN=$ORDER(^LAB(62.4,IEN))

               IF IEN<1

                   QUIT

               Begin DoDot:1

 +5                DO SAVE(62.4,IEN_",",FLD,"")

               End DoDot:1

 +6        IF $GET(LRDBUG)

               QUIT

628       ;Save values from ^LAHM(62.8  fields 1.13,1.23,2.13,2.23,2.33

 +1        DO PRT(62.8)

 +2        KILL OUT,ERR,FLD,FLD9,VAL,FLDV,IENX

 +3        KILL ^XTMP("LR302",62.801)

 +4        SET FLD9="1.14;1.24;2.14;2.24;2.34"

           SET IEN=0

 +5        SET FLD="1.13;1.23;2.13;2.23;2.33"

 +6        FOR

               SET IEN=$ORDER(^LAHM(62.8,IEN))

               IF IEN<1

                   QUIT

               Begin DoDot:1

 +7                SET IEN2=0

FOR

                       SET IEN2=$ORDER(^LAHM(62.8,IEN,10,IEN2))

                       IF IEN2<1

                           QUIT

                       Begin DoDot:2

 +8                        SET IENX=IEN2_","_IEN_","

                           DO SAVE(62.801,IENX,FLD,"")

 +9                        DO SAVE(62.801,IENX,FLD9,95.3)

                       End DoDot:2

               End DoDot:1

 +10       IF $GET(LRDBUG)

               QUIT

6285      ;Extract data from ^LAHM(62.85  field .05

 +1        DO PRT(62.85)

 +2        KILL IEN,FLD,OUT,ERR

 +3        KILL ^XTMP("LR302",62.85)

 +4        SET IEN=0

           SET FLD=.05

FOR

               SET IEN=$ORDER(^LAHM(62.85,IEN))

               IF IEN<1

                   QUIT

               Begin DoDot:1

 +5                DO SAVE(62.85,IEN_",",FLD,"")

               End DoDot:1

 +6        IF $GET(LRDBUG)

               QUIT

629       ; Extract data from ^LAHM(62.9,,60 fields 1.15,1.25,2.15,2.25,2.35

 +1        DO PRT(62.9)

 +2        KILL IEN,IEN2,IENX,FLD,FLD9,OUT,ERR

 +3        KILL ^XTMP("LR302",62.9001)

 +4        SET FLD="1.15;1.25;2.15;2.25;2.35"

 +5        SET FLD9="1.16;1.26;2.16;2.26;2.36"

           SET IEN=0

 +6        FOR

               SET IEN=$ORDER(^LAHM(62.9,IEN))

               IF IEN<1

                   QUIT

               Begin DoDot:1

 +7                SET IEN2=0

FOR

                       SET IEN2=$ORDER(^LAHM(62.9,IEN,60,IEN2))

                       IF IEN2<1

                           QUIT

                       Begin DoDot:2

 +8                        SET IENX=IEN2_","_IEN_","

                           DO SAVE(62.9001,IENX,FLD,"")

 +9                        DO SAVE(62.9001,IENX,FLD9,95.3)

                       End DoDot:2

               End DoDot:1

 +10       IF $GET(LRDBUG)

               QUIT

 +11       GOTO 642

6402      ;Save values from ^LAM(IEN,5,IEN2,1 fields

 +1        NEW FLD2,OUT,ERR,LRD,IEN2,LRI2,LRI3

 +2        SET FLD2=".01;1"

 +3        SET LRI2=0

FOR

               SET LRI2=$ORDER(^LAM(LRI,5,LRI2))

               IF LRI2<1

                   QUIT

               Begin DoDot:1

 +4                SET LRI3=0

FOR

                       SET LRI3=$ORDER(^LAM(LRI,5,LRI2,1,LRI3))

                       IF LRI3<1

                           QUIT

                       Begin DoDot:2

 +5                        SET IEN2=LRI3_","_LRI2_","_LRI_","

 +6                        DO SAVE(64.02,IEN2,4,95.3)

 +7                        DO SAVE(64.02,IEN2,FLD2,"")

                       End DoDot:2

               End DoDot:1

 +8        QUIT

642       ;Save values from ^LAB(64.2  1,4,7,8,9,15

 +1        DO PRT(64.2)

 +2        KILL FLD,IEN,^XTMP("LR302",64.2)

 +3        SET FLD="1;4;7;8;9;15"

 +4        SET IEN=0

FOR

               SET IEN=$ORDER(^LAB(64.2,IEN))

               IF IEN<1

                   QUIT

               Begin DoDot:1

 +5                DO SAVE(64.2,IEN_",",FLD,"")

               End DoDot:1

 +6        IF $GET(LRDBUG)

               QUIT

682       ;Extract date for ^LRO(68.2,  field .14

 +1        DO PRT(68.2)

 +2        KILL FLD,IEN,^XTMP("LR302",68.2)

 +3        SET FLD=.14

 +4        SET IEN=0

FOR

               SET IEN=$ORDER(^LRO(68.2,IEN))

               IF IEN<1

                   QUIT

               Begin DoDot:1

 +5                DO SAVE(68.2,IEN_",",FLD,"")

               End DoDot:1

 +6        IF $GET(LRDBUG)

               QUIT

696       ;

 +1        DO PRT(69.6)

 +2        KILL FLD,FLD2,IEN,IEN2

 +3        KILL ^XTMP("LR302",69.6),^(69.64)

 +4        SET FLD=6

           SET FLD2=5

           SET IEN=0

 +5        FOR

               SET IEN=$ORDER(^LRO(69.6,IEN))

               IF IEN<1

                   QUIT

               Begin DoDot:1

 +6                DO SAVE(69.6,IEN_",",FLD,"")

 +7                SET IEN2=0

FOR

                       SET IEN2=$ORDER(^LRO(69.6,IEN,2,IEN2))

                       IF IEN2<1

                           QUIT

                       Begin DoDot:2

 +8                        DO SAVE(69.64,IEN2_","_IEN_",",FLD2,"")

                       End DoDot:2

               End DoDot:1

 +9        IF $GET(LRDBUG)

               QUIT

 +10       SET ^XTMP("LR302",1,0)=$$NOW^XLFDT_U_"Historical pointers saved"

 +11       QUIT

SAVE(FILE,IENX,FLD,LNC) ;Save Data  (FILE #,IEN,Fields,95.3)

 +1        KILL OUT,ERR,VAL,FLDP,FLDV

 +2        IF $GET(IEN)

               IF (IEN#400=0)

                   WRITE "."

 +3        DO GETS^DIQ(FILE,IENX,FLD,"E","OUT","ERR")

 +4        FOR FLDP=1:1

               SET FLDV=$PIECE(FLD,";",FLDP)

               IF '$LENGTH(FLDV)

                   QUIT

               Begin DoDot:1

 +5                SET VAL=$GET(OUT(FILE,IENX,FLDV,"E"))

                   IF $LENGTH(VAL)

                       Begin DoDot:2

 +6                        SET ^XTMP("LR302",FILE,IENX,FLDV)=$SELECT(LNC=95.3:+VAL,1:VAL)

                       End DoDot:2

               End DoDot:1

 +7        QUIT

PRT(FILE) ;Display file name

 +1        DO BMES^LR302("Saving File #"_FILE_" data.")

 +2        WRITE !

 +3        QUIT

LR302A.m