Routine: PXVRPC3

PXVRPC3 ;MSC/DKA - VIMM 2.0 RPC code to return list of Immunizations ;10/27/2015 13:36

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**215**;Aug 12, 1996;Build 10

IMMDATA(PXVRET,PXVFLTR,SUBFILES) ; Return array of entries from IMMUNIZATION, File #9999999.14

 ; PXVFLTR can have one of these values:

 ;   R:XXX - Return entry with IEN XXX.

 ;   S:A   - List of Active Immunizations (default)

 ;   S:H   - List of [Selectable for] Historic Immunizations

 ;   S:*   - All records (Including Inactive Immunizations)

 ; SUBFILES is 1 or Y to include the subfiles when returning the data

 ; If SUBFILES is 0 or N (or not specified) then return just this subset of fields:

 ; IEN, NAME, SHORT NAME, CVX CODE, MAX # IN SERIES, INACTIVE FLAG,

 ; MNEMONIC, ACRONYM, SELECTABLE FOR HISTORIC)

 N PXVFILE,PXVIEN,PXVIENS,PXVCNT,PXVGBL,PXVDATA,PXVSTR,PXVREF,PXVERR,PXVSUB,PXVSUBC,PXVDELIM,PXVSBSCR

 N PXVBRIEF,PXVACTIV,PXVHISTR,PXVINCLU,PXVTEMP,PXVDLM1,PXVDLM2,PXVDLM3,PXVVALID,PXVERMSG,PXVTYPE

 N PXVSDATA,PXVSERR,PXVFMT,PXVSUB2,PXVSUB2C,PXVSVSC2

 S SUBFILES=+$TR($E($G(SUBFILES,0)),"YyNn","1100")

 S PXVFLTR=$G(PXVFLTR,"S:A") S:PXVFLTR="" PXVFLTR="S:A"

 S PXVGBL=$NA(^AUTTIMM)

 K PXVRET S PXVRET=$NA(^TMP("PXVRPC3",$J)) K @PXVRET

 S PXVVALID=1 ; Assume the parameters are valid until proven otherwise

 I $E(PXVFLTR,1,2)="R:" D

 . S PXVFMT="R",PXVIEN=$E(PXVFLTR,3,$L(PXVFLTR)),PXVTYPE="*"

 . S:PXVIEN'=+PXVIEN!(PXVIEN<1) PXVVALID=0,PXVERMSG="Invalid IEN specified for R: format in PXVFLTR parameter"

 . Q:PXVIEN=""

 . S:'$D(@PXVGBL@(PXVIEN)) PXVVALID=0,PXVERMSG="Entry not found for the specified IEN"

 E  I $E(PXVFLTR,1,2)="S:" D

 . S PXVFMT="S",PXVTYPE=$E(PXVFLTR,3)

 . S:PXVTYPE'="A"&(PXVTYPE'="H")&(PXVTYPE'="*") PXVVALID=0,PXVERMSG="Invalid type specified for S: format in PXVFLTR parameter"

 . S ACTONLY=PXVTYPE'="H" ; ActiveOnly is any type (A or *) except H

 . S SELHIST=PXVTYPE'="A" ; Selectable for Historic is any type (H or *) except A

 E  S PXVVALID=0,PXVERMSG="Invalid Parameter(s)"

 I 'PXVVALID S @PXVRET@(0)=-1_U_PXVERMSG Q

 S PXVBRIEF=".01;.02;.03;.05;.07;8801;8802;8803"

 S PXVCNT=0

 S PXVFILE=9999999.14

 I PXVFMT="R" D

 . D GETFLDS

 E  I PXVFMT="S" D

 . S PXVIEN=0

 . F  S PXVIEN=$O(@PXVGBL@(PXVIEN)) Q:'PXVIEN  D GETFLDS

 S @PXVRET@(0)=PXVCNT ; Put the number of returned records in the first node of the array

GETFLDS ; Get fields for one IEN

 S PXVIENS=PXVIEN_","

 K PXVDATA,PXVERR

 I 'SUBFILES D GETS^DIQ(PXVFILE,PXVIENS,PXVBRIEF,"I","PXVDATA","PXVERR")

 I SUBFILES D GETS^DIQ(PXVFILE,PXVIENS,"**","IE","PXVDATA","PXVERR")

 S PXVREF=$NA(PXVDATA(PXVFILE,PXVIENS))

 S PXVSTR=""

 S $P(PXVSTR,U,1)=PXVIEN

 ; NAME

 S $P(PXVSTR,U,2)=@PXVREF@(.01,"I")

 S $P(PXVSTR,U,3)=@PXVREF@(.02,"I")

 S $P(PXVSTR,U,4)=@PXVREF@(.03,"I")

 S $P(PXVSTR,U,5)=@PXVREF@(.05,"I")

 ; INACTIVE FLAG - Return 0 or 1 instead of "" or 1

 S (PXVTEMP,$P(PXVSTR,U,6))=+@PXVREF@(.07,"I")

 S PXVACTIV='PXVTEMP

 S $P(PXVSTR,U,7)=@PXVREF@(8801,"I")

 S $P(PXVSTR,U,8)=@PXVREF@(8802,"I")

 S (PXVTEMP,$P(PXVSTR,U,9))=@PXVREF@(8803,"I")

 S PXVHISTR=PXVTEMP="Y"

 S PXVINCLU=1 ; Assume the record is to be included until proven otherwise

 I PXVFMT'="R",PXVTYPE'="*" D

 . I ACTONLY,'PXVACTIV S PXVINCLU=0

 . E  I SELHIST,'PXVHISTR S PXVINCLU=0

 Q:'PXVINCLU

 D:SUBFILES SUBFILES

 S PXVCNT=PXVCNT+1

 S @PXVRET@(PXVCNT)=PXVSTR

SUBFILES ; Add the subfile multiples to the array

 ; Subfiles:

 S PXVDLM1="|",PXVDLM2="~",PXVDLM3=";;"

 ; Field 2 - CDC FULL VACCINE NAME

 ; There's only one entry in Field 2 for each Immunization, but that may change

 S PXVSUB="",PXVSUBC=0

 F  S PXVSUBC=PXVSUBC+1 Q:'$D(@PXVREF@(2,PXVSUBC))  D

 . S $P(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(2,PXVSUBC)

 S $P(PXVSTR,U,10)=PXVSUB

 ; Field 3 - CODING SYSTEM

 S PXVREF=$NA(PXVDATA(PXVFILE_"3"))

 S PXVSBSCR="",PXVSUB="",PXVSUBC=0

 F  S PXVSBSCR=$O(@PXVREF@(PXVSBSCR)) Q:PXVSBSCR=""  D

 . S PXVSUBC=PXVSUBC+1

 . K PXVSDATA,PXVSERR

 . D GETS^DIQ(PXVFILE_"3",PXVSBSCR,"**","","PXVSDATA","PXVSERR")

 . S PXVSVSC2="",PXVSUB2C=0,PXVSUB2=""

 . F  S PXVSVSC2=$O(PXVSDATA(PXVFILE_"31",PXVSVSC2)) Q:PXVSVSC2=""  D

 . . S PXVSUB2C=PXVSUB2C+1

 . . S $P(PXVSUB2,PXVDLM3,PXVSUB2C)=PXVSDATA(PXVFILE_"31",PXVSVSC2,.01)

 . S $P(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")_PXVDLM2_PXVSUB2

 S $P(PXVSTR,U,11)=PXVSUB

 ; Field 4 - VACCINE INFORMATION STATEMENT

 S PXVREF=$NA(PXVDATA(PXVFILE_"4"))

 S PXVSBSCR="",PXVSUB="",PXVSUBC=0

 F  S PXVSBSCR=$O(@PXVREF@(PXVSBSCR)) Q:PXVSBSCR=""  D

 . S PXVSUBC=PXVSUBC+1

 . S $P(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")_PXVDLM2_@PXVREF@(PXVSBSCR,.01,"E")

 S $P(PXVSTR,U,12)=PXVSUB

 ; Field 5 - CDC PRODUCT NAME

 S PXVREF=$NA(PXVDATA(PXVFILE_"5"))

 S PXVSBSCR="",PXVSUB="",PXVSUBC=0

 F  S PXVSBSCR=$O(@PXVREF@(PXVSBSCR)) Q:PXVSBSCR=""  D

 . S PXVSUBC=PXVSUBC+1

 . S $P(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")

 S $P(PXVSTR,U,13)=PXVSUB

 ; Field 7 - VACCINE GROUP NAME

 S PXVREF=$NA(PXVDATA(PXVFILE_"7"))

 S PXVSBSCR="",PXVSUB="",PXVSUBC=0

 F  S PXVSBSCR=$O(@PXVREF@(PXVSBSCR)) Q:PXVSBSCR=""  D

 . S PXVSUBC=PXVSUBC+1

 . S $P(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")

 S $P(PXVSTR,U,14)=PXVSUB

 ; Field 10 - SYNONYM

 S PXVREF=$NA(PXVDATA(PXVFILE_"1"))

 S PXVSBSCR="",PXVSUB="",PXVSUBC=0

 F  S PXVSBSCR=$O(@PXVREF@(PXVSBSCR)) Q:PXVSBSCR=""  D

 . S PXVSUBC=PXVSUBC+1

 . S $P(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")

 S $P(PXVSTR,U,15)=PXVSUB

 ; Field 99.991 - EFFECTIVE DATE/TIME

 S PXVREF=$NA(PXVDATA(PXVFILE_"99"))

 S PXVSBSCR="",PXVSUB="",PXVSUBC=0

 F  S PXVSBSCR=$O(@PXVREF@(PXVSBSCR)) Q:PXVSBSCR=""  D

 . S PXVSUBC=PXVSUBC+1

 . S $P(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")_PXVDLM2_@PXVREF@(PXVSBSCR,.02,"I")

 S $P(PXVSTR,U,16)=PXVSUB

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVRPC3   5773     printed  Feb 18, 2025@23:58:16                                                                                                                                                                                                     Page 2

PXVRPC3   ;MSC/DKA - VIMM 2.0 RPC code to return list of Immunizations ;10/27/2015 13:36

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**215**;Aug 12, 1996;Build 10

 +2       ;

 +3        QUIT

IMMDATA(PXVRET,PXVFLTR,SUBFILES) ; Return array of entries from IMMUNIZATION, File #9999999.14

 +1       ; PXVFLTR can have one of these values:

 +2       ;   R:XXX - Return entry with IEN XXX.

 +3       ;   S:A   - List of Active Immunizations (default)

 +4       ;   S:H   - List of [Selectable for] Historic Immunizations

 +5       ;   S:*   - All records (Including Inactive Immunizations)

 +6       ; SUBFILES is 1 or Y to include the subfiles when returning the data

 +7       ; If SUBFILES is 0 or N (or not specified) then return just this subset of fields:

 +8       ; IEN, NAME, SHORT NAME, CVX CODE, MAX # IN SERIES, INACTIVE FLAG,

 +9       ; MNEMONIC, ACRONYM, SELECTABLE FOR HISTORIC)

 +10       NEW PXVFILE,PXVIEN,PXVIENS,PXVCNT,PXVGBL,PXVDATA,PXVSTR,PXVREF,PXVERR,PXVSUB,PXVSUBC,PXVDELIM,PXVSBSCR

 +11       NEW PXVBRIEF,PXVACTIV,PXVHISTR,PXVINCLU,PXVTEMP,PXVDLM1,PXVDLM2,PXVDLM3,PXVVALID,PXVERMSG,PXVTYPE

 +12       NEW PXVSDATA,PXVSERR,PXVFMT,PXVSUB2,PXVSUB2C,PXVSVSC2

 +13       SET SUBFILES=+$TRANSLATE($EXTRACT($GET(SUBFILES,0)),"YyNn","1100")

 +14       SET PXVFLTR=$GET(PXVFLTR,"S:A")

           if PXVFLTR=""

               SET PXVFLTR="S:A"

 +15       SET PXVGBL=$NAME(^AUTTIMM)

 +16       KILL PXVRET

           SET PXVRET=$NAME(^TMP("PXVRPC3",$JOB))

           KILL @PXVRET

 +17      ; Assume the parameters are valid until proven otherwise

           SET PXVVALID=1

 +18       IF $EXTRACT(PXVFLTR,1,2)="R:"

               Begin DoDot:1

 +19               SET PXVFMT="R"

                   SET PXVIEN=$EXTRACT(PXVFLTR,3,$LENGTH(PXVFLTR))

                   SET PXVTYPE="*"

 +20               if PXVIEN'=+PXVIEN!(PXVIEN<1)

                       SET PXVVALID=0

                       SET PXVERMSG="Invalid IEN specified for R: format in PXVFLTR parameter"

 +21               if PXVIEN=""

                       QUIT

 +22               if '$DATA(@PXVGBL@(PXVIEN))

                       SET PXVVALID=0

                       SET PXVERMSG="Entry not found for the specified IEN"

               End DoDot:1

 +23      IF '$TEST

               IF $EXTRACT(PXVFLTR,1,2)="S:"

                   Begin DoDot:1

 +24                   SET PXVFMT="S"

                       SET PXVTYPE=$EXTRACT(PXVFLTR,3)

 +25                   if PXVTYPE'="A"&(PXVTYPE'="H")&(PXVTYPE'="*")

                           SET PXVVALID=0

                           SET PXVERMSG="Invalid type specified for S: format in PXVFLTR parameter"

 +26      ; ActiveOnly is any type (A or *) except H

                       SET ACTONLY=PXVTYPE'="H"

 +27      ; Selectable for Historic is any type (H or *) except A

                       SET SELHIST=PXVTYPE'="A"

                   End DoDot:1

 +28      IF '$TEST

               SET PXVVALID=0

               SET PXVERMSG="Invalid Parameter(s)"

 +29       IF 'PXVVALID

               SET @PXVRET@(0)=-1_U_PXVERMSG

               QUIT

 +30       SET PXVBRIEF=".01;.02;.03;.05;.07;8801;8802;8803"

 +31       SET PXVCNT=0

 +32       SET PXVFILE=9999999.14

 +33       IF PXVFMT="R"

               Begin DoDot:1

 +34               DO GETFLDS

               End DoDot:1

 +35      IF '$TEST

               IF PXVFMT="S"

                   Begin DoDot:1

 +36                   SET PXVIEN=0

 +37                   FOR

                           SET PXVIEN=$ORDER(@PXVGBL@(PXVIEN))

                           if 'PXVIEN

                               QUIT

                           DO GETFLDS

                   End DoDot:1

 +38      ; Put the number of returned records in the first node of the array

           SET @PXVRET@(0)=PXVCNT

 +39       QUIT

GETFLDS   ; Get fields for one IEN

 +1        SET PXVIENS=PXVIEN_","

 +2        KILL PXVDATA,PXVERR

 +3        IF 'SUBFILES

               DO GETS^DIQ(PXVFILE,PXVIENS,PXVBRIEF,"I","PXVDATA","PXVERR")

 +4        IF SUBFILES

               DO GETS^DIQ(PXVFILE,PXVIENS,"**","IE","PXVDATA","PXVERR")

 +5        SET PXVREF=$NAME(PXVDATA(PXVFILE,PXVIENS))

 +6        SET PXVSTR=""

 +7        SET $PIECE(PXVSTR,U,1)=PXVIEN

 +8       ; NAME

 +9        SET $PIECE(PXVSTR,U,2)=@PXVREF@(.01,"I")

 +10       SET $PIECE(PXVSTR,U,3)=@PXVREF@(.02,"I")

 +11       SET $PIECE(PXVSTR,U,4)=@PXVREF@(.03,"I")

 +12       SET $PIECE(PXVSTR,U,5)=@PXVREF@(.05,"I")

 +13      ; INACTIVE FLAG - Return 0 or 1 instead of "" or 1

 +14       SET (PXVTEMP,$PIECE(PXVSTR,U,6))=+@PXVREF@(.07,"I")

 +15       SET PXVACTIV='PXVTEMP

 +16       SET $PIECE(PXVSTR,U,7)=@PXVREF@(8801,"I")

 +17       SET $PIECE(PXVSTR,U,8)=@PXVREF@(8802,"I")

 +18       SET (PXVTEMP,$PIECE(PXVSTR,U,9))=@PXVREF@(8803,"I")

 +19       SET PXVHISTR=PXVTEMP="Y"

 +20      ; Assume the record is to be included until proven otherwise

           SET PXVINCLU=1

 +21       IF PXVFMT'="R"

               IF PXVTYPE'="*"

                   Begin DoDot:1

 +22                   IF ACTONLY

                           IF 'PXVACTIV

                               SET PXVINCLU=0

 +23                  IF '$TEST

                           IF SELHIST

                               IF 'PXVHISTR

                                   SET PXVINCLU=0

                   End DoDot:1

 +24       if 'PXVINCLU

               QUIT

 +25       if SUBFILES

               DO SUBFILES

 +26       SET PXVCNT=PXVCNT+1

 +27       SET @PXVRET@(PXVCNT)=PXVSTR

 +28       QUIT

SUBFILES  ; Add the subfile multiples to the array

 +1       ; Subfiles:

 +2        SET PXVDLM1="|"

           SET PXVDLM2="~"

           SET PXVDLM3=";;"

 +3       ; Field 2 - CDC FULL VACCINE NAME

 +4       ; There's only one entry in Field 2 for each Immunization, but that may change

 +5        SET PXVSUB=""

           SET PXVSUBC=0

 +6        FOR

               SET PXVSUBC=PXVSUBC+1

               if '$DATA(@PXVREF@(2,PXVSUBC))

                   QUIT

               Begin DoDot:1

 +7                SET $PIECE(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(2,PXVSUBC)

               End DoDot:1

 +8        SET $PIECE(PXVSTR,U,10)=PXVSUB

 +9       ; Field 3 - CODING SYSTEM

 +10       SET PXVREF=$NAME(PXVDATA(PXVFILE_"3"))

 +11       SET PXVSBSCR=""

           SET PXVSUB=""

           SET PXVSUBC=0

 +12       FOR

               SET PXVSBSCR=$ORDER(@PXVREF@(PXVSBSCR))

               if PXVSBSCR=""

                   QUIT

               Begin DoDot:1

 +13               SET PXVSUBC=PXVSUBC+1

 +14               KILL PXVSDATA,PXVSERR

 +15               DO GETS^DIQ(PXVFILE_"3",PXVSBSCR,"**","","PXVSDATA","PXVSERR")

 +16               SET PXVSVSC2=""

                   SET PXVSUB2C=0

                   SET PXVSUB2=""

 +17               FOR

                       SET PXVSVSC2=$ORDER(PXVSDATA(PXVFILE_"31",PXVSVSC2))

                       if PXVSVSC2=""

                           QUIT

                       Begin DoDot:2

 +18                       SET PXVSUB2C=PXVSUB2C+1

 +19                       SET $PIECE(PXVSUB2,PXVDLM3,PXVSUB2C)=PXVSDATA(PXVFILE_"31",PXVSVSC2,.01)

                       End DoDot:2

 +20               SET $PIECE(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")_PXVDLM2_PXVSUB2

               End DoDot:1

 +21       SET $PIECE(PXVSTR,U,11)=PXVSUB

 +22      ; Field 4 - VACCINE INFORMATION STATEMENT

 +23       SET PXVREF=$NAME(PXVDATA(PXVFILE_"4"))

 +24       SET PXVSBSCR=""

           SET PXVSUB=""

           SET PXVSUBC=0

 +25       FOR

               SET PXVSBSCR=$ORDER(@PXVREF@(PXVSBSCR))

               if PXVSBSCR=""

                   QUIT

               Begin DoDot:1

 +26               SET PXVSUBC=PXVSUBC+1

 +27               SET $PIECE(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")_PXVDLM2_@PXVREF@(PXVSBSCR,.01,"E")

               End DoDot:1

 +28       SET $PIECE(PXVSTR,U,12)=PXVSUB

 +29      ; Field 5 - CDC PRODUCT NAME

 +30       SET PXVREF=$NAME(PXVDATA(PXVFILE_"5"))

 +31       SET PXVSBSCR=""

           SET PXVSUB=""

           SET PXVSUBC=0

 +32       FOR

               SET PXVSBSCR=$ORDER(@PXVREF@(PXVSBSCR))

               if PXVSBSCR=""

                   QUIT

               Begin DoDot:1

 +33               SET PXVSUBC=PXVSUBC+1

 +34               SET $PIECE(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")

               End DoDot:1

 +35       SET $PIECE(PXVSTR,U,13)=PXVSUB

 +36      ; Field 7 - VACCINE GROUP NAME

 +37       SET PXVREF=$NAME(PXVDATA(PXVFILE_"7"))

 +38       SET PXVSBSCR=""

           SET PXVSUB=""

           SET PXVSUBC=0

 +39       FOR

               SET PXVSBSCR=$ORDER(@PXVREF@(PXVSBSCR))

               if PXVSBSCR=""

                   QUIT

               Begin DoDot:1

 +40               SET PXVSUBC=PXVSUBC+1

 +41               SET $PIECE(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")

               End DoDot:1

 +42       SET $PIECE(PXVSTR,U,14)=PXVSUB

 +43      ; Field 10 - SYNONYM

 +44       SET PXVREF=$NAME(PXVDATA(PXVFILE_"1"))

 +45       SET PXVSBSCR=""

           SET PXVSUB=""

           SET PXVSUBC=0

 +46       FOR

               SET PXVSBSCR=$ORDER(@PXVREF@(PXVSBSCR))

               if PXVSBSCR=""

                   QUIT

               Begin DoDot:1

 +47               SET PXVSUBC=PXVSUBC+1

 +48               SET $PIECE(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")

               End DoDot:1

 +49       SET $PIECE(PXVSTR,U,15)=PXVSUB

 +50      ; Field 99.991 - EFFECTIVE DATE/TIME

 +51       SET PXVREF=$NAME(PXVDATA(PXVFILE_"99"))

 +52       SET PXVSBSCR=""

           SET PXVSUB=""

           SET PXVSUBC=0

 +53       FOR

               SET PXVSBSCR=$ORDER(@PXVREF@(PXVSBSCR))

               if PXVSBSCR=""

                   QUIT

               Begin DoDot:1

 +54               SET PXVSUBC=PXVSUBC+1

 +55               SET $PIECE(PXVSUB,PXVDLM1,PXVSUBC)=@PXVREF@(PXVSBSCR,.01,"I")_PXVDLM2_@PXVREF@(PXVSBSCR,.02,"I")

               End DoDot:1

 +56       SET $PIECE(PXVSTR,U,16)=PXVSUB

 +57       QUIT

PXVRPC3.m