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 Apr 09, 2024@21:32:47 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
