PXRPC ;ISL/JLC - PCE DATA2PCE RPC ;Jul 20, 2021@08:24:07
;;1.0;PCE PATIENT CARE ENCOUNTER;**200,209,210,215,216,211,217**;Aug 12, 1996;Build 134
;
; Reference to UCUMDATA^LEXMUCUM supported by ICR #6225
;
;
SAVE(OK,PCELIST,LOC,PKGNAME,SRC,PXAVST,PXRETVST) ; save PCE information
;
N PXRET
;
D SAVE2(.PXRET,.PCELIST,.PKGNAME,.SRC,.PXAVST)
S OK=$G(PXRET(0))
I '$G(PXRETVST) S OK=$P(OK,U,1)
Q
;
SAVE2(OK,PCELIST,PKGNAME,SRC,PXAVST) ; save PCE information - and return err info
;
N PXAPI,PXERRTYP,PKG,PROBLEMS,PXAPREDT,PXIMMRDAPI
;
S PXERRTYP="INPUT_ERR"
;
I $G(PKGNAME)="" D Q
. S OK(0)=-3
. S OK(1)=PXERRTYP_U_U_U_U_U_"Package Name argument not defined."
I $G(SRC)="" D Q
. S OK(0)=-3
. S OK(1)=PXERRTYP_U_U_U_U_U_"Source argument not defined."
S PKG=$$PKG2IEN^VSIT(PKGNAME)
I PKG=-1 D Q
. S OK(0)=-3
. S OK(1)=PXERRTYP_U_U_U_U_U_"Package, '"_PKGNAME_"', does not exist in the Package file (#9.4)."
;
D DQSAVE(.PCELIST,.PXAPI,.PROBLEMS,.SRC,.PXIMMRDAPI)
I '$D(PXAPI) D Q
. S OK(0)=-3
. S OK(1)=PXERRTYP_U_U_U_U_U_"'PCELIST' argument not valid."
;
S PXAPREDT=1 ;Flag to allow edit of primary provider
D DATA2PCE(.OK,"PXAPI",PKG,SRC,PXAPREDT,.PXAVST)
;
; save immunization reading (for smallpox) in a seperate DATA2PCE call
; as it is part of the placement visit.
I $D(PXIMMRDAPI) D
. D IMMREAD(.OK,.PXIMMRDAPI,PKG,SRC,PXAPREDT)
;
Q
;
IMMREAD(OK,PXIMMRDAPI,PKG,SRC) ; save immunization reading (for smallpox)
;
N PXAPREDT,PXERROR,PXERRCOUNT,PXI,PXTEMP,PXVISIT,OK2
;
S PXERRCOUNT=+$O(OK(""),-1)
;
S PXERROR=$G(PXIMMRDAPI("IMMUNIZATION",1,"ERROR"))
S PXVISIT=$G(PXIMMRDAPI("IMMUNIZATION",1,"VISIT"))
K PXIMMRDAPI("IMMUNIZATION",1,"ERROR")
K PXIMMRDAPI("IMMUNIZATION",1,"VISIT")
I PXERROR'="" D Q
. I +OK(0)>0 S $P(OK(0),U,1)=-1
. S PXERRCOUNT=PXERRCOUNT+1
. S OK(PXERRCOUNT)="ERROR_IMM_READING"_U_U_U_U_U_PXERROR
I 'PXVISIT D Q
. I +OK(0)>0 S $P(OK(0),U,1)=-1
. S PXERRCOUNT=PXERRCOUNT+1
. S OK(PXERRCOUNT)="ERROR_IMM_READING"_U_U_U_U_U_"Could not file Immunization Reading, as the Placement Visit could not be obtained."
;
S PXAPREDT=1 ;Flag to allow edit of primary provider
D DATA2PCE(.OK2,"PXIMMRDAPI",PKG,SRC,PXAPREDT,PXVISIT)
I +OK2(0)<0,+OK(0)>0 S $P(OK(0),U,1)=$P(OK2(0),U,1)
S PXI=0
F S PXI=$O(OK2(PXI)) Q:'PXI D
. S PXERRCOUNT=PXERRCOUNT+1
. S PXTEMP=$G(OK2(PXI))
. S OK(PXERRCOUNT)=$P(PXTEMP,U,1)_"_IMM_READING"_U_$P(PXTEMP,U,2,99)
;
Q
;
DQSAVE(PCELIST,PXPCEARR,PROBLEMS,SRC,PXPCEIMMRD) ;
;
; Processes PCELIST input array and creates a new array in a format
; that can be passed into DATA2PCE^PXAPI.
;
;Input:
; .PCELIST - (Required) Array passed by reference.
; This should be in the same format as the PX SAVE DATA
; and ORWPCE SAVE RPCs' PCELIST input parameter.
; .PXPCEARR - (Required) The root of an array passed by reference
; that this API will populate based off the PCELIST
; argument. This array will be in a format that can be
; passed into DATA2PCE^PXAPI.
; .PROBLEMS - (Required) This API will populate this array with POV
; entries that are marked to be added to the Problem List.
; .SRC - (Required) The source of the data - such as 'TEXT
; INTEGRATION UTILITIES'. This API can possibly change the
; value of SRC, depending on the Health Factor (HF) values
; contained in PCELIST.
;.PXPCEIMMRD - (Required) The root of an array passed by reference
; that this API will populate based off the PCELIST argument.
; It will only be populated if there is an immunization
; reading. This array will be in a format that can be passed
; into DATA2PCE^PXAPI.
;
;
D DQSAVE^PXRPC1(.PCELIST,.PXPCEARR,.PROBLEMS,.SRC,.PXPCEIMMRD)
Q
;
;
DATA2PCE(OK,PXPCEARR,PKG,SRC,PXAPREDT,PXAVST) ;
N PXERROR,PXERRPROB
I '($D(PXAVST)#2) S PXAVST=""
S OK(0)=$$DATA2PCE^PXAI(PXPCEARR,PKG,SRC,.PXAVST,"",0,.PXERROR,PXAPREDT,.PXERRPROB)
S OK(0)=OK(0)_U_$G(PXAVST)
D ERROR(.OK,.PXERROR,.PXERRPROB)
;
Q
;
ERROR(PXRET,PXERROR,PXERRPROB) ; Return errors
;
N PXERRCOUNT,PXERRTYP,PXFIELD,PXFILE,PXIEN,PXMSG,PXNODE,PXNUM,PXSUB
;
I '$D(PXERRPROB),'$D(PXERROR) Q
S PXERRCOUNT=0
;
S PXNODE="PXERROR"
S PXERRTYP="ERROR_FILING"
F S PXNODE=$Q(@PXNODE) Q:PXNODE="" D
. S PXFILE=$QS(PXNODE,1)
. S PXNUM=$QS(PXNODE,2)
. S PXIEN=$QS(PXNODE,3)
. S PXFIELD=$QS(PXNODE,4)
. S PXSUB=$QS(PXNODE,5)
. I PXSUB'="" S PXFIELD=PXFIELD_","_PXSUB
. S PXMSG=$G(@PXNODE)
. S PXERRCOUNT=PXERRCOUNT+1
. S PXRET(PXERRCOUNT)=PXERRTYP_U_PXFILE_U_PXNUM_U_PXIEN_U_PXFIELD_U_PXMSG
;
S PXNODE="PXERRPROB"
F S PXNODE=$Q(@PXNODE) Q:PXNODE="" D
. S PXERRTYP=$QS(PXNODE,3)
. S PXFILE=$QS(PXNODE,4)
. S PXFIELD=$QS(PXNODE,5)
. S PXNUM=$QS(PXNODE,6)
. S PXMSG=$G(@PXNODE)
. I PXFILE="PX/DL",PXERRTYP="ERROR4" D
. . S PXNUM=PXFIELD
. . S PXFIELD=""
. I PXFILE="ENCOUNTER",PXERRTYP="WARNING3" D
. . S PXFIELD=PXNUM
. . S PXNUM=1
. S PXERRCOUNT=PXERRCOUNT+1
. S PXRET(PXERRCOUNT)=PXERRTYP_U_PXFILE_U_PXNUM_U_U_PXFIELD_U_PXMSG
;
Q
;
IMMSRC(IMMIS) ; Returns Event Info Source IEN
N IMMISHL,IMMISIEN,X
S IMMISHL=$P(IMMIS,";",1)
S IMMISIEN=$P(IMMIS,";",2)
; Look up the value in the "H" Cross-reference
I 'IMMISIEN D
. S IMMISIEN=$$FIND1^DIC(920.1,,,IMMISHL,"H",,"IMMISERR")
Q IMMISIEN
;
IMMROUTE(IMMRT) ; Returns Route IEN
N IMMRTHL,IMMRTIEN,IMMRTNM,X
S IMMRTNM=$P(IMMRT,";",1)
S IMMRTHL=$P(IMMRT,";",2)
S IMMRTIEN=$P(IMMRT,";",3)
I 'IMMRTIEN,IMMRTHL'="" D
. S IMMRTIEN=$$FIND1^DIC(920.2,,,IMMRTHL,"H",,"IMMRTERR")
I 'IMMRTIEN,IMMRTNM'="" D
. S IMMRTIEN=$$FIND1^DIC(920.2,,,IMMRTNM,"B",,"IMMRTERR")
Q IMMRTIEN
;
IMMLOC(IMMAL) ; Returns Anatomic Location IEN
N IMMALHL,IMMALIEN,IMMALNM,X
S IMMALNM=$P(IMMAL,";",1)
S IMMALHL=$P(IMMAL,";",2)
S IMMALIEN=$P(IMMAL,";",3)
I 'IMMALIEN,IMMALHL'="" D
. S IMMALIEN=$$FIND1^DIC(920.3,,,IMMALHL,"B",,"IMMALERR")
I 'IMMALIEN,IMMALNM'="" D
. S IMMALIEN=$$FIND1^DIC(920.3,,,IMMALNM,"B",,"IMMALERR")
Q IMMALIEN
;
IMMLOT(IMMLOT,IMMMANUF,IMMEXPDT) ; Returns Lot_IEN^Comment
N IMMCOMM,IMMLOTIEN,IMMLOTNM,X
S IMMLOTNM=$P(IMMLOT,";",1)
S IMMLOTIEN=$P(IMMLOT,";",2)
;
I IMMLOTIEN Q IMMLOTIEN
;
; If the Lot Number, Manufacturer and Expiration Date are all specified,
; then find an entry matching all three values in File 9999999.41 (IMMUNIZATION LOT)
; If we don't find a match, then add the fields to the Comment.
; For now, we will not receive the Expiration Date from Walgreens, so we always update the Comment.
S IMMCOMM=""
S:IMMLOTNM'="" IMMCOMM=IMMCOMM_$S(IMMCOMM="":"",1:" ")_"Lot#: "_IMMLOTNM
S:IMMMANUF'="" IMMCOMM=IMMCOMM_$S(IMMCOMM="":"",1:" ")_"Mfr: "_IMMMANUF
S:IMMEXPDT'="" IMMCOMM=IMMCOMM_$S(IMMCOMM="":"",1:" ")_"Expiration Date: "_IMMEXPDT
Q "^"_IMMCOMM
;
IMMVIS(IMMVISMULT,PXPCEARR,IMM) ; Sets PXPCEARR's VIS multiple
N IMMVIS,IMMVISDT,IMMVISENTRY,PXSEQ,PXX,X
S PXSEQ=0
F PXX=1:1:$L(IMMVISMULT,";") D
. S IMMVISENTRY=$$TRIM^XLFSTR($P(IMMVISMULT,";",PXX))
. S IMMVIS=$P(IMMVISENTRY,"/",1)
. I 'IMMVIS Q
. S IMMVISDT=$P(IMMVISENTRY,"/",2)
. I IMMVISDT S IMMVIS=IMMVIS_U_IMMVISDT
. S PXSEQ=PXSEQ+1
. S PXPCEARR("IMMUNIZATION",IMM,"VIS",PXSEQ,0)=IMMVIS
Q
;
IMMRMRKS(IMMREMARKS,IMMNUM,REMARK) ; Sets REMARK array
N PXEND,PXSTART,PXX,X
S PXSTART=$P(IMMREMARKS,";",1)
S PXEND=$P(IMMREMARKS,";",2)
I ('PXSTART)!('PXEND)!(PXEND<PXSTART) Q
F PXX=PXSTART:1:PXEND D
. S REMARK(PXX)="IMMUNIZATION^"_IMMNUM
Q
;
IMMDSG(IMMDSG) ;
N IMMDOSE,IMMUNIT,IMMUNITIEN,IMMDOSEV,IMMUNERR,X
S IMMDSG=$$TRIM^XLFSTR(IMMDSG)
I IMMDSG="" Q ""
S IMMDOSE=$P(IMMDSG,";",1)
S IMMUNIT=$P(IMMDSG,";",2)
S IMMUNITIEN=$P(IMMDSG,";",3)
I IMMDSG[" ",IMMDSG'[";" D ;Remove this DO block when VLER DAS starts using ";" between dose and units
. S IMMDOSE=$P(IMMDSG," ",1)
. S IMMUNIT=$P(IMMDSG," ",2)
;
I IMMDOSE="" Q ""
;
I IMMUNIT'="",'IMMUNITIEN D
. N UCUMDATA
. D UCUMDATA^LEXMUCUM(IMMUNIT,.UCUMDATA) ; ICR 6225
. S IMMUNITIEN=$O(UCUMDATA(0))
D CHK^DIE(9000010.11,1312,,IMMDOSE,.IMMDOSEV,"IMMUNERR")
I IMMUNITIEN,IMMDOSEV'="^" Q IMMDOSEV_U_IMMUNITIEN
;
Q U_U_"Dosage: "_IMMDOSE_" "_IMMUNIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRPC 8403 printed Apr 09, 2024@21:29:20 Page 2
PXRPC ;ISL/JLC - PCE DATA2PCE RPC ;Jul 20, 2021@08:24:07
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**200,209,210,215,216,211,217**;Aug 12, 1996;Build 134
+2 ;
+3 ; Reference to UCUMDATA^LEXMUCUM supported by ICR #6225
+4 ;
+5 ;
SAVE(OK,PCELIST,LOC,PKGNAME,SRC,PXAVST,PXRETVST) ; save PCE information
+1 ;
+2 NEW PXRET
+3 ;
+4 DO SAVE2(.PXRET,.PCELIST,.PKGNAME,.SRC,.PXAVST)
+5 SET OK=$GET(PXRET(0))
+6 IF '$GET(PXRETVST)
SET OK=$PIECE(OK,U,1)
+7 QUIT
+8 ;
SAVE2(OK,PCELIST,PKGNAME,SRC,PXAVST) ; save PCE information - and return err info
+1 ;
+2 NEW PXAPI,PXERRTYP,PKG,PROBLEMS,PXAPREDT,PXIMMRDAPI
+3 ;
+4 SET PXERRTYP="INPUT_ERR"
+5 ;
+6 IF $GET(PKGNAME)=""
Begin DoDot:1
+7 SET OK(0)=-3
+8 SET OK(1)=PXERRTYP_U_U_U_U_U_"Package Name argument not defined."
End DoDot:1
QUIT
+9 IF $GET(SRC)=""
Begin DoDot:1
+10 SET OK(0)=-3
+11 SET OK(1)=PXERRTYP_U_U_U_U_U_"Source argument not defined."
End DoDot:1
QUIT
+12 SET PKG=$$PKG2IEN^VSIT(PKGNAME)
+13 IF PKG=-1
Begin DoDot:1
+14 SET OK(0)=-3
+15 SET OK(1)=PXERRTYP_U_U_U_U_U_"Package, '"_PKGNAME_"', does not exist in the Package file (#9.4)."
End DoDot:1
QUIT
+16 ;
+17 DO DQSAVE(.PCELIST,.PXAPI,.PROBLEMS,.SRC,.PXIMMRDAPI)
+18 IF '$DATA(PXAPI)
Begin DoDot:1
+19 SET OK(0)=-3
+20 SET OK(1)=PXERRTYP_U_U_U_U_U_"'PCELIST' argument not valid."
End DoDot:1
QUIT
+21 ;
+22 ;Flag to allow edit of primary provider
SET PXAPREDT=1
+23 DO DATA2PCE(.OK,"PXAPI",PKG,SRC,PXAPREDT,.PXAVST)
+24 ;
+25 ; save immunization reading (for smallpox) in a seperate DATA2PCE call
+26 ; as it is part of the placement visit.
+27 IF $DATA(PXIMMRDAPI)
Begin DoDot:1
+28 DO IMMREAD(.OK,.PXIMMRDAPI,PKG,SRC,PXAPREDT)
End DoDot:1
+29 ;
+30 QUIT
+31 ;
IMMREAD(OK,PXIMMRDAPI,PKG,SRC) ; save immunization reading (for smallpox)
+1 ;
+2 NEW PXAPREDT,PXERROR,PXERRCOUNT,PXI,PXTEMP,PXVISIT,OK2
+3 ;
+4 SET PXERRCOUNT=+$ORDER(OK(""),-1)
+5 ;
+6 SET PXERROR=$GET(PXIMMRDAPI("IMMUNIZATION",1,"ERROR"))
+7 SET PXVISIT=$GET(PXIMMRDAPI("IMMUNIZATION",1,"VISIT"))
+8 KILL PXIMMRDAPI("IMMUNIZATION",1,"ERROR")
+9 KILL PXIMMRDAPI("IMMUNIZATION",1,"VISIT")
+10 IF PXERROR'=""
Begin DoDot:1
+11 IF +OK(0)>0
SET $PIECE(OK(0),U,1)=-1
+12 SET PXERRCOUNT=PXERRCOUNT+1
+13 SET OK(PXERRCOUNT)="ERROR_IMM_READING"_U_U_U_U_U_PXERROR
End DoDot:1
QUIT
+14 IF 'PXVISIT
Begin DoDot:1
+15 IF +OK(0)>0
SET $PIECE(OK(0),U,1)=-1
+16 SET PXERRCOUNT=PXERRCOUNT+1
+17 SET OK(PXERRCOUNT)="ERROR_IMM_READING"_U_U_U_U_U_"Could not file Immunization Reading, as the Placement Visit could not be obtained."
End DoDot:1
QUIT
+18 ;
+19 ;Flag to allow edit of primary provider
SET PXAPREDT=1
+20 DO DATA2PCE(.OK2,"PXIMMRDAPI",PKG,SRC,PXAPREDT,PXVISIT)
+21 IF +OK2(0)<0
IF +OK(0)>0
SET $PIECE(OK(0),U,1)=$PIECE(OK2(0),U,1)
+22 SET PXI=0
+23 FOR
SET PXI=$ORDER(OK2(PXI))
if 'PXI
QUIT
Begin DoDot:1
+24 SET PXERRCOUNT=PXERRCOUNT+1
+25 SET PXTEMP=$GET(OK2(PXI))
+26 SET OK(PXERRCOUNT)=$PIECE(PXTEMP,U,1)_"_IMM_READING"_U_$PIECE(PXTEMP,U,2,99)
End DoDot:1
+27 ;
+28 QUIT
+29 ;
DQSAVE(PCELIST,PXPCEARR,PROBLEMS,SRC,PXPCEIMMRD) ;
+1 ;
+2 ; Processes PCELIST input array and creates a new array in a format
+3 ; that can be passed into DATA2PCE^PXAPI.
+4 ;
+5 ;Input:
+6 ; .PCELIST - (Required) Array passed by reference.
+7 ; This should be in the same format as the PX SAVE DATA
+8 ; and ORWPCE SAVE RPCs' PCELIST input parameter.
+9 ; .PXPCEARR - (Required) The root of an array passed by reference
+10 ; that this API will populate based off the PCELIST
+11 ; argument. This array will be in a format that can be
+12 ; passed into DATA2PCE^PXAPI.
+13 ; .PROBLEMS - (Required) This API will populate this array with POV
+14 ; entries that are marked to be added to the Problem List.
+15 ; .SRC - (Required) The source of the data - such as 'TEXT
+16 ; INTEGRATION UTILITIES'. This API can possibly change the
+17 ; value of SRC, depending on the Health Factor (HF) values
+18 ; contained in PCELIST.
+19 ;.PXPCEIMMRD - (Required) The root of an array passed by reference
+20 ; that this API will populate based off the PCELIST argument.
+21 ; It will only be populated if there is an immunization
+22 ; reading. This array will be in a format that can be passed
+23 ; into DATA2PCE^PXAPI.
+24 ;
+25 ;
+26 DO DQSAVE^PXRPC1(.PCELIST,.PXPCEARR,.PROBLEMS,.SRC,.PXPCEIMMRD)
+27 QUIT
+28 ;
+29 ;
DATA2PCE(OK,PXPCEARR,PKG,SRC,PXAPREDT,PXAVST) ;
+1 NEW PXERROR,PXERRPROB
+2 IF '($DATA(PXAVST)#2)
SET PXAVST=""
+3 SET OK(0)=$$DATA2PCE^PXAI(PXPCEARR,PKG,SRC,.PXAVST,"",0,.PXERROR,PXAPREDT,.PXERRPROB)
+4 SET OK(0)=OK(0)_U_$GET(PXAVST)
+5 DO ERROR(.OK,.PXERROR,.PXERRPROB)
+6 ;
+7 QUIT
+8 ;
ERROR(PXRET,PXERROR,PXERRPROB) ; Return errors
+1 ;
+2 NEW PXERRCOUNT,PXERRTYP,PXFIELD,PXFILE,PXIEN,PXMSG,PXNODE,PXNUM,PXSUB
+3 ;
+4 IF '$DATA(PXERRPROB)
IF '$DATA(PXERROR)
QUIT
+5 SET PXERRCOUNT=0
+6 ;
+7 SET PXNODE="PXERROR"
+8 SET PXERRTYP="ERROR_FILING"
+9 FOR
SET PXNODE=$QUERY(@PXNODE)
if PXNODE=""
QUIT
Begin DoDot:1
+10 SET PXFILE=$QSUBSCRIPT(PXNODE,1)
+11 SET PXNUM=$QSUBSCRIPT(PXNODE,2)
+12 SET PXIEN=$QSUBSCRIPT(PXNODE,3)
+13 SET PXFIELD=$QSUBSCRIPT(PXNODE,4)
+14 SET PXSUB=$QSUBSCRIPT(PXNODE,5)
+15 IF PXSUB'=""
SET PXFIELD=PXFIELD_","_PXSUB
+16 SET PXMSG=$GET(@PXNODE)
+17 SET PXERRCOUNT=PXERRCOUNT+1
+18 SET PXRET(PXERRCOUNT)=PXERRTYP_U_PXFILE_U_PXNUM_U_PXIEN_U_PXFIELD_U_PXMSG
End DoDot:1
+19 ;
+20 SET PXNODE="PXERRPROB"
+21 FOR
SET PXNODE=$QUERY(@PXNODE)
if PXNODE=""
QUIT
Begin DoDot:1
+22 SET PXERRTYP=$QSUBSCRIPT(PXNODE,3)
+23 SET PXFILE=$QSUBSCRIPT(PXNODE,4)
+24 SET PXFIELD=$QSUBSCRIPT(PXNODE,5)
+25 SET PXNUM=$QSUBSCRIPT(PXNODE,6)
+26 SET PXMSG=$GET(@PXNODE)
+27 IF PXFILE="PX/DL"
IF PXERRTYP="ERROR4"
Begin DoDot:2
+28 SET PXNUM=PXFIELD
+29 SET PXFIELD=""
End DoDot:2
+30 IF PXFILE="ENCOUNTER"
IF PXERRTYP="WARNING3"
Begin DoDot:2
+31 SET PXFIELD=PXNUM
+32 SET PXNUM=1
End DoDot:2
+33 SET PXERRCOUNT=PXERRCOUNT+1
+34 SET PXRET(PXERRCOUNT)=PXERRTYP_U_PXFILE_U_PXNUM_U_U_PXFIELD_U_PXMSG
End DoDot:1
+35 ;
+36 QUIT
+37 ;
IMMSRC(IMMIS) ; Returns Event Info Source IEN
+1 NEW IMMISHL,IMMISIEN,X
+2 SET IMMISHL=$PIECE(IMMIS,";",1)
+3 SET IMMISIEN=$PIECE(IMMIS,";",2)
+4 ; Look up the value in the "H" Cross-reference
+5 IF 'IMMISIEN
Begin DoDot:1
+6 SET IMMISIEN=$$FIND1^DIC(920.1,,,IMMISHL,"H",,"IMMISERR")
End DoDot:1
+7 QUIT IMMISIEN
+8 ;
IMMROUTE(IMMRT) ; Returns Route IEN
+1 NEW IMMRTHL,IMMRTIEN,IMMRTNM,X
+2 SET IMMRTNM=$PIECE(IMMRT,";",1)
+3 SET IMMRTHL=$PIECE(IMMRT,";",2)
+4 SET IMMRTIEN=$PIECE(IMMRT,";",3)
+5 IF 'IMMRTIEN
IF IMMRTHL'=""
Begin DoDot:1
+6 SET IMMRTIEN=$$FIND1^DIC(920.2,,,IMMRTHL,"H",,"IMMRTERR")
End DoDot:1
+7 IF 'IMMRTIEN
IF IMMRTNM'=""
Begin DoDot:1
+8 SET IMMRTIEN=$$FIND1^DIC(920.2,,,IMMRTNM,"B",,"IMMRTERR")
End DoDot:1
+9 QUIT IMMRTIEN
+10 ;
IMMLOC(IMMAL) ; Returns Anatomic Location IEN
+1 NEW IMMALHL,IMMALIEN,IMMALNM,X
+2 SET IMMALNM=$PIECE(IMMAL,";",1)
+3 SET IMMALHL=$PIECE(IMMAL,";",2)
+4 SET IMMALIEN=$PIECE(IMMAL,";",3)
+5 IF 'IMMALIEN
IF IMMALHL'=""
Begin DoDot:1
+6 SET IMMALIEN=$$FIND1^DIC(920.3,,,IMMALHL,"B",,"IMMALERR")
End DoDot:1
+7 IF 'IMMALIEN
IF IMMALNM'=""
Begin DoDot:1
+8 SET IMMALIEN=$$FIND1^DIC(920.3,,,IMMALNM,"B",,"IMMALERR")
End DoDot:1
+9 QUIT IMMALIEN
+10 ;
IMMLOT(IMMLOT,IMMMANUF,IMMEXPDT) ; Returns Lot_IEN^Comment
+1 NEW IMMCOMM,IMMLOTIEN,IMMLOTNM,X
+2 SET IMMLOTNM=$PIECE(IMMLOT,";",1)
+3 SET IMMLOTIEN=$PIECE(IMMLOT,";",2)
+4 ;
+5 IF IMMLOTIEN
QUIT IMMLOTIEN
+6 ;
+7 ; If the Lot Number, Manufacturer and Expiration Date are all specified,
+8 ; then find an entry matching all three values in File 9999999.41 (IMMUNIZATION LOT)
+9 ; If we don't find a match, then add the fields to the Comment.
+10 ; For now, we will not receive the Expiration Date from Walgreens, so we always update the Comment.
+11 SET IMMCOMM=""
+12 if IMMLOTNM'=""
SET IMMCOMM=IMMCOMM_$SELECT(IMMCOMM="":"",1:" ")_"Lot#: "_IMMLOTNM
+13 if IMMMANUF'=""
SET IMMCOMM=IMMCOMM_$SELECT(IMMCOMM="":"",1:" ")_"Mfr: "_IMMMANUF
+14 if IMMEXPDT'=""
SET IMMCOMM=IMMCOMM_$SELECT(IMMCOMM="":"",1:" ")_"Expiration Date: "_IMMEXPDT
+15 QUIT "^"_IMMCOMM
+16 ;
IMMVIS(IMMVISMULT,PXPCEARR,IMM) ; Sets PXPCEARR's VIS multiple
+1 NEW IMMVIS,IMMVISDT,IMMVISENTRY,PXSEQ,PXX,X
+2 SET PXSEQ=0
+3 FOR PXX=1:1:$LENGTH(IMMVISMULT,";")
Begin DoDot:1
+4 SET IMMVISENTRY=$$TRIM^XLFSTR($PIECE(IMMVISMULT,";",PXX))
+5 SET IMMVIS=$PIECE(IMMVISENTRY,"/",1)
+6 IF 'IMMVIS
QUIT
+7 SET IMMVISDT=$PIECE(IMMVISENTRY,"/",2)
+8 IF IMMVISDT
SET IMMVIS=IMMVIS_U_IMMVISDT
+9 SET PXSEQ=PXSEQ+1
+10 SET PXPCEARR("IMMUNIZATION",IMM,"VIS",PXSEQ,0)=IMMVIS
End DoDot:1
+11 QUIT
+12 ;
IMMRMRKS(IMMREMARKS,IMMNUM,REMARK) ; Sets REMARK array
+1 NEW PXEND,PXSTART,PXX,X
+2 SET PXSTART=$PIECE(IMMREMARKS,";",1)
+3 SET PXEND=$PIECE(IMMREMARKS,";",2)
+4 IF ('PXSTART)!('PXEND)!(PXEND<PXSTART)
QUIT
+5 FOR PXX=PXSTART:1:PXEND
Begin DoDot:1
+6 SET REMARK(PXX)="IMMUNIZATION^"_IMMNUM
End DoDot:1
+7 QUIT
+8 ;
IMMDSG(IMMDSG) ;
+1 NEW IMMDOSE,IMMUNIT,IMMUNITIEN,IMMDOSEV,IMMUNERR,X
+2 SET IMMDSG=$$TRIM^XLFSTR(IMMDSG)
+3 IF IMMDSG=""
QUIT ""
+4 SET IMMDOSE=$PIECE(IMMDSG,";",1)
+5 SET IMMUNIT=$PIECE(IMMDSG,";",2)
+6 SET IMMUNITIEN=$PIECE(IMMDSG,";",3)
+7 ;Remove this DO block when VLER DAS starts using ";" between dose and units
IF IMMDSG[" "
IF IMMDSG'[";"
Begin DoDot:1
+8 SET IMMDOSE=$PIECE(IMMDSG," ",1)
+9 SET IMMUNIT=$PIECE(IMMDSG," ",2)
End DoDot:1
+10 ;
+11 IF IMMDOSE=""
QUIT ""
+12 ;
+13 IF IMMUNIT'=""
IF 'IMMUNITIEN
Begin DoDot:1
+14 NEW UCUMDATA
+15 ; ICR 6225
DO UCUMDATA^LEXMUCUM(IMMUNIT,.UCUMDATA)
+16 SET IMMUNITIEN=$ORDER(UCUMDATA(0))
End DoDot:1
+17 DO CHK^DIE(9000010.11,1312,,IMMDOSE,.IMMDOSEV,"IMMUNERR")
+18 IF IMMUNITIEN
IF IMMDOSEV'="^"
QUIT IMMDOSEV_U_IMMUNITIEN
+19 ;
+20 QUIT U_U_"Dosage: "_IMMDOSE_" "_IMMUNIT
