- 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
- ;
- Q
- 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
- Q
- 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
- Q
- 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
- Q
- --- 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