PXRPC1 ;ISL/JLC,GN - PCE DATA2PCE RPC Cont ;Aug 04, 2025@08:51:23
;;1.0;PCE PATIENT CARE ENCOUNTER;**217,244**;Aug 12, 1996;Build 37
;
; References to ICDEX supported by ICR #5747
;
DQSAVE(PCELIST,PXPCEARR,PROBLEMS,SRC,PXPCEIMMRD) ;
;
; Called from DQSAVE^PXRPC
;
N TYP,CODE,IEN,I,X
N CAT,NARR,PXENCDT
N PRV,CPT,ICD,IMM,SC,SK,PED,HF,XAM,TRT,ICR,MOD,MODCNT,MODIDX,MODS
N COM,COMMENT,COMMENTS,SVCAT
N DFN,PXAPREDT
; Vars for Info Source (IMMIS) Imm. Admin Route (IMMRT), Body Site (IMMAL), Lot, Manufacturer, Exp. Date & Comments
N IMMISNM,IMMISIEN,IMMRTNM,IMMRTIEN,IMMRTERR,IMMALNAME,IMMALIEN,IMMALERR,IMMLOT,IMMMANUF,IMMEXPDT,IMMCOMM,IMMCOMMS,IMMLOTIEN
N NUM,REMARK,SEQ,IMMDSG,IMMCVX,IMMCVXER,IMMOVERRIDE,IMMRDCOM,SKRDCOM,PXVIMM
S (PRV,CPT,ICD,IMM,SC,SK,PED,HF,XAM,TRT,ICR)=0
S I="" F S I=$O(PCELIST(I)) Q:'I S X=PCELIST(I) D
. S X=PCELIST(I),TYP=$P(X,U),CODE=$P(X,U,2),CAT=$P(X,U,3),NARR=$P(X,U,4)
. I $E(TYP,1,3)="PRV" D Q
. . Q:'$L(CODE)
. . S PRV=PRV+1
. . S PXAPREDT=1 ;Set the flag to allow editing of primary provider
. . S PXPCEARR("PROVIDER",PRV,"NAME")=CODE
. . S PXPCEARR("PROVIDER",PRV,"PRIMARY")=$P(X,U,6)
. . I $E(TYP,4)="-" S PXPCEARR("PROVIDER",PRV,"DELETE")=1
. I TYP="VST" D Q
. . I CODE="DT" S (PXENCDT,PXPCEARR("ENCOUNTER",1,"ENC D/T"))=$P(X,U,3) Q
. . I CODE="PT" S PXPCEARR("ENCOUNTER",1,"PATIENT")=$P(X,U,3),DFN=$P(X,U,3) Q
. . I CODE="HL" S PXPCEARR("ENCOUNTER",1,"HOS LOC")=$P(X,U,3) Q
. . I CODE="PR" S PXPCEARR("ENCOUNTER",1,"PARENT")=$P(X,U,3) Q
. . I CODE="ET" S PXPCEARR("ENCOUNTER",1,"ENCOUNTER TYPE")=$P(X,U,3) Q
. . ;prevents checkout!
. . I CODE="VC" S (SVCAT,PXPCEARR("ENCOUNTER",1,"SERVICE CATEGORY"))=$P(X,U,3) Q
. . I CODE="OL" D Q
. . . I +$P(X,U,3) S PXPCEARR("ENCOUNTER",1,"INSTITUTION")=$P(X,U,3)
. . . E I $P(X,U,4)'="",$P(X,U,4)'="0" S PXPCEARR("ENCOUNTER",1,"OUTSIDE LOCATION")=$P(X,U,4)
. . I $$FINDBYCODE^PXSPECAUTH(CODE) S PXPCEARR("ENCOUNTER",1,CODE)=$P(X,U,3) Q
. I $E(TYP,1,3)="CPT" D Q
. . Q:'$L(CODE)
. . S CPT=CPT+1
. . S IEN=$$CODEN^ICPTCOD(CODE) ;ICR #1995
. . S PXPCEARR("PROCEDURE",CPT,"PROCEDURE")=IEN
. . I +$P(X,U,9) D
. . . S MODS=$P(X,U,9),MODCNT=+MODS
. . . F MODIDX=1:1:MODCNT D
. . . . S MOD=$P($P(MODS,";",MODIDX+1),"/")
. . . . S PXPCEARR("PROCEDURE",CPT,"MODIFIERS",MOD)=""
. . S:$L(CAT) PXPCEARR("PROCEDURE",CPT,"CATEGORY")=CAT
. . S:$L(NARR) PXPCEARR("PROCEDURE",CPT,"NARRATIVE")=NARR
. . S:$L($P(X,U,5)) PXPCEARR("PROCEDURE",CPT,"QTY")=$P(X,U,5)
. . S:$P(X,U,6)>0 PXPCEARR("PROCEDURE",CPT,"ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PROCEDURE^"_CPT
. . I $E(TYP,4)="-" S PXPCEARR("PROCEDURE",CPT,"DELETE")=1,PXPCEARR("PROCEDURE",CPT,"QTY")=0
. I $E(TYP,1,3)="POV" D Q
. . N PXDXI,PXDX
. . Q:'$L(CODE)
. . F PXDXI=1:1:$L(CODE,"/") D
. . . N CSYS,CDT,IEN,LEXIEN
. . . S PXDX=$P(CODE,"/",PXDXI)
. . . S ICD=ICD+1
. . . I (PXDX]""),(PXDX'[".") S PXDX=PXDX_"."
. . . S IEN=$P($$CODEN^ICDEX(PXDX,80),"~",1)
. . . I IEN'>0 Q
. . . S PXPCEARR("DX/PL",ICD,"DIAGNOSIS")=IEN
. . . S PXPCEARR("DX/PL",ICD,"PRIMARY")=$S(PXDXI=1:$P(X,U,5),1:0)
. . . S CDT=$S($G(SVCAT)="E":DT,1:$G(PXENCDT))
. . . S CSYS=$$CSI^ICDEX(80,IEN)
. . . S LEXIEN=$P($$EXP^LEXCODE(PXDX,CSYS,CDT),U),PXPCEARR("DX/PL",ICD,"LEXICON TERM")=$S(LEXIEN>0:LEXIEN,1:"")
. . . S:$L(CAT) PXPCEARR("DX/PL",ICD,"CATEGORY")=CAT
. . . S:$L(NARR) PXPCEARR("DX/PL",ICD,"NARRATIVE")=NARR
. . . S:$P(X,U,6)>0 PXPCEARR("DX/PL",ICD,"ENC PROVIDER")=$P(X,U,6)
. . . I $L($P(X,U,7)),($P(X,U,7)=1),(PXDXI=1) S PXPCEARR("DX/PL",ICD,"PL ADD")=$P(X,U,7),PROBLEMS(ICD)=NARR_U_CODE
. . . S:$L($P(X,U,10))>0&(PXDXI=1) COMMENT($P(X,U,10))="DX/PL^"_ICD
. . . I $E(TYP,4)="-" S PXPCEARR("DX/PL",ICD,"DELETE")=1
. I $E(TYP,1,3)="IMM" D Q
. . ; If the CVX Code is present, then use it to find the corresponding Immunization,
. . ; but only if the Immunization IEN is not specified
. . S IMMCVX=$P(X,U,11)
. . I CODE="",IMMCVX'="" D
. . . D CVXTOIEN^PXAPIIM(.CODE,IMMCVX)
. . . S CODE=$P(CODE,U,1)
. . Q:'$L(CODE)
. . ;
. . ; if this is for a smallpox reading, file this as an update against the original
. . ; Visit/V Immunization entry.
. . ; (Piece 30 is for the V Immunization IEN. It should only be populated when doing
. . ; a reading).
. . S PXVIMM=$P(X,U,30)
. . I PXVIMM D Q
. . . I '$D(^AUPNVIMM(PXVIMM,0)) D Q
. . . . S PXPCEIMMRD("IMMUNIZATION",1,"ERROR")="V Immunization IEN (#"_PXVIMM_") does not exist. Cannot save reading."
. . . I $G(DFN),DFN'=$P($G(^AUPNVIMM(PXVIMM,0)),U,2) D Q
. . . . S PXPCEIMMRD("IMMUNIZATION",1,"ERROR")="Patient IEN does not match previous V Immunization entry (#"_PXVIMM_"). Cannot save reading."
. . . S PXPCEIMMRD("IMMUNIZATION",1,"VISIT")=$P($G(^AUPNVIMM(PXVIMM,0)),U,3)
. . . S PXPCEIMMRD("IMMUNIZATION",1,"IMMUN")=CODE
. . . ; Reading fields (for smallpox)
. . . S:$P(X,U,25)'="" PXPCEIMMRD("IMMUNIZATION",1,"RESULT")=$P(X,U,25)
. . . S:$P(X,U,26)'="" PXPCEIMMRD("IMMUNIZATION",1,"READING")=$P(X,U,26)
. . . S:$P(X,U,27)'="" PXPCEIMMRD("IMMUNIZATION",1,"D/T READ")=$P(X,U,27)
. . . S:$P(X,U,28)>0 PXPCEIMMRD("IMMUNIZATION",1,"READER")=$P(X,U,28)
. . . I $P(X,U,29)>0 S IMMRDCOM($P(X,U,29))="IMMUNIZATION^1"
. . ;
. . S IMM=IMM+1
. . S PXPCEARR("IMMUNIZATION",IMM,"IMMUN")=CODE
. . I IMMCVX'="" S PXPCEARR("IMMUNIZATION",IMM,"CVX")=IMMCVX
. . S:$L($P(X,U,5)) PXPCEARR("IMMUNIZATION",IMM,"SERIES")=$P(X,U,5)
. . S:$L($P(X,U,7)) PXPCEARR("IMMUNIZATION",IMM,"REACTION")=$P(X,U,7)
. . S:$L($P(X,U,8)) PXPCEARR("IMMUNIZATION",IMM,"CONTRAINDICATED")=$P(X,U,8)
. . S:$L($P(X,U,9)) PXPCEARR("IMMUNIZATION",IMM,"REFUSED")=$P(X,U,9)
. . S:$P(X,U,6)>0 PXPCEARR("IMMUNIZATION",IMM,"ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMMUNIZATION^"_IMM
. . ; These are the additional fields being added by PX*1.0*209
. . S IMMISIEN=$$IMMSRC^PXRPC($P(X,U,12))
. . S:IMMISIEN PXPCEARR("IMMUNIZATION",IMM,"INFO SOURCE")=IMMISIEN
. . S IMMRTIEN=$$IMMROUTE^PXRPC($P(X,U,14))
. . S:IMMRTIEN PXPCEARR("IMMUNIZATION",IMM,"ADMIN ROUTE")=IMMRTIEN
. . S IMMALIEN=$$IMMLOC^PXRPC($P(X,U,15))
. . S:IMMALIEN'="" PXPCEARR("IMMUNIZATION",IMM,"ANATOMIC LOC")=IMMALIEN
. . S IMMLOT=$$IMMLOT^PXRPC($P(X,U,16),$P(X,U,17),$P(X,U,18))
. . S IMMLOTIEN=$P(IMMLOT,"^",1)
. . S IMMCOMM=$P(IMMLOT,"^",2)
. . S:IMMLOTIEN PXPCEARR("IMMUNIZATION",IMM,"LOT NUM")=IMMLOTIEN
. . S IMMDSG=$$IMMDSG^PXRPC($P(X,U,13))
. . I $P(IMMDSG,U,1)'="" D
. . . S PXPCEARR("IMMUNIZATION",IMM,"DOSE")=$P(IMMDSG,U,1)
. . . I $P(IMMDSG,U,2) S PXPCEARR("IMMUNIZATION",IMM,"DOSE UNITS")=$P(IMMDSG,U,2)
. . I $P(IMMDSG,U,3)'="" D ; add Dosage to comments
. . . S IMMCOMM=$S($G(IMMCOMM)'="":IMMCOMM_"; ",1:"")_$P(IMMDSG,U,3)
. . I IMMCOMM'="" D
. . . ; If we have something to add to the Imm comment, either add it to the existing comment
. . . ; (if one exists) or just set it in the COMMENT field.
. . . I $L($P(X,U,10)) S IMMCOMMS($P(X,U,10))=IMMCOMM ; This will get added later to the existing comment
. . . E S PXPCEARR("IMMUNIZATION",IMM,"COMMENT")=IMMCOMM
. . S:$P(X,U,19)>0 PXPCEARR("IMMUNIZATION",IMM,"EVENT D/T")=$P(X,U,19)
. . I $P(X,U,20)'="" S PXPCEARR("IMMUNIZATION",IMM,"ORD PROVIDER")=$P(X,U,20)
. . I $P(X,U,21)'="" D IMMVIS^PXRPC($P(X,U,21),.PXPCEARR,IMM)
. . I $P(X,U,22)'="" D IMMRMRKS^PXRPC($P(X,U,22),IMM,.REMARK)
. . I $P(X,U,23)'="" S PXPCEARR("IMMUNIZATION",IMM,"WARNING ACK")=$P(X,U,23)
. . I $P(X,U,24)>0 S IMMOVERRIDE($P(X,U,24))="IMMUNIZATION^"_IMM
. . I $P(X,U,31)'="" S PXPCEARR("IMMUNIZATION",IMM,"ORD BY POLICY")=$P(X,U,31)
. . I $E(TYP,4)="-" S PXPCEARR("IMMUNIZATION",IMM,"DELETE")=1
. I $E(TYP,1,2)="SK" D Q
. . Q:'$L(CODE)
. . S SK=SK+1
. . S PXPCEARR("SKIN TEST",SK,"TEST")=CODE
. . S:$L($P(X,U,5)) PXPCEARR("SKIN TEST",SK,"RESULT")=$P(X,U,5)
. . S:$P(X,U,6)>0 PXPCEARR("SKIN TEST",SK,"ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,7)) PXPCEARR("SKIN TEST",SK,"READING")=$P(X,U,7)
. . S:$L($P(X,U,8)) PXPCEARR("SKIN TEST",SK,"D/T READ")=$P(X,U,8)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="SKIN TEST^"_SK
. . S:$P(X,U,11)>0 PXPCEARR("SKIN TEST",SK,"READER")=$P(X,U,11)
. . I $P(X,U,14)>0 S SKRDCOM($P(X,U,14))="SKIN TEST^"_SK
. . S IMMALIEN=$$IMMLOC^PXRPC($P(X,U,15))
. . S:IMMALIEN PXPCEARR("SKIN TEST",SK,"ANATOMIC LOC")=IMMALIEN
. . I $P(X,U,16)>0 S PXPCEARR("SKIN TEST",SK,"PLACEMENT")=$P(X,U,16)
. . S:$L($P(X,U,19)) PXPCEARR("SKIN TEST",SK,"EVENT D/T")=$P(X,U,19)
. . S:$P(X,U,20)>0 PXPCEARR("SKIN TEST",SK,"ORD PROVIDER")=$P(X,U,20)
. . I $E(TYP,3)="-" S PXPCEARR("SKIN TEST",SK,"DELETE")=1
. I $E(TYP,1,3)="PED" D Q
. . Q:'$L(CODE)
. . S PED=PED+1
. . S PXPCEARR("PATIENT ED",PED,"TOPIC")=CODE
. . S:$L($P(X,U,5)) PXPCEARR("PATIENT ED",PED,"UNDERSTANDING")=$P(X,U,5)
. . S:$P(X,U,6)>0 PXPCEARR("PATIENT ED",PED,"ENC PROVIDER")=$P(X,U,6)
. . I $P(X,U,7)'="" S PXPCEARR("PATIENT ED",PED,"MAGNITUDE")=$P(X,U,7)
. . I $P(X,U,8)'="" S PXPCEARR("PATIENT ED",PED,"UCUM CODE")=$P(X,U,8)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="PATIENT ED^"_PED
. . I $E(TYP,4)="-" S PXPCEARR("PATIENT ED",PED,"DELETE")=1
. I $E(TYP,1,2)="HF" D Q
. . Q:'$L(CODE)
. . S HF=HF+1
. . S PXPCEARR("HEALTH FACTOR",HF,"HEALTH FACTOR")=CODE
. . S:$L($P(X,U,5)) PXPCEARR("HEALTH FACTOR",HF,"LEVEL/SEVERITY")=$P(X,U,5)
. . S:$P(X,U,6)'>0 $P(X,U,6)=$G(PXPCEARR("PROVIDER",1,"NAME"))
. . S:$P(X,U,6)>0 PXPCEARR("HEALTH FACTOR",HF,"ENC PROVIDER")=$P(X,U,6)
. . I $P(X,U,7)'="" S PXPCEARR("HEALTH FACTOR",HF,"MAGNITUDE")=$P(X,U,7)
. . I $P(X,U,8)'="" S PXPCEARR("HEALTH FACTOR",HF,"UCUM CODE")=$P(X,U,8)
. . S:$L($P(X,U,11)) PXPCEARR("HEALTH FACTOR",HF,"EVENT D/T")=$P($P(X,U,11),";",1)
. . S:$L($P(X,U,11)) SRC=$P($P(X,U,11),";",2)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="HEALTH FACTOR^"_HF
. . I $E(TYP,3)="-" S PXPCEARR("HEALTH FACTOR",HF,"DELETE")=1
. I $E(TYP,1,3)="XAM" D Q
. . Q:'$L(CODE)
. . S XAM=XAM+1
. . S PXPCEARR("EXAM",XAM,"EXAM")=CODE
. . S:$L($P(X,U,5)) PXPCEARR("EXAM",XAM,"RESULT")=$P(X,U,5)
. . S:$P(X,U,6)>0 PXPCEARR("EXAM",XAM,"ENC PROVIDER")=$P(X,U,6)
. . I $P(X,U,7)'="" S PXPCEARR("EXAM",XAM,"MAGNITUDE")=$P(X,U,7)
. . I $P(X,U,8)'="" S PXPCEARR("EXAM",XAM,"UCUM CODE")=$P(X,U,8)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="EXAM^"_XAM
. . I $E(TYP,4)="-" S PXPCEARR("EXAM",XAM,"DELETE")=1
. I $E(TYP,1,3)="TRT" D Q
. . Q:'$L(CODE)
. . S TRT=TRT+1
. . S PXPCEARR("TREATMENT",TRT,"IMMUN")=CODE
. . S:$L(CAT) PXPCEARR("TREATMENT",TRT,"CATEGORY")=CAT
. . S:$L(NARR) PXPCEARR("TREATMENT",TRT,"NARRATIVE")=NARR
. . S:$L($P(X,U,5)) PXPCEARR("TREATMENT",TRT,"QTY")=$P(X,U,5)
. . S:$P(X,U,6)>0 PXPCEARR("TREATMENT",TRT,"ENC PROVIDER")=$P(X,U,6)
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="TREATMENT^"_TRT
. . I $E(TYP,4)="-" S PXPCEARR("TREATMENT",TRT,"DELETE")=1,PXPCEARR("TREATMENT",TRT,"QTY")=0
. I $E(TYP,1,3)="ICR" D Q
. . Q:'$L(CODE)
. . S ICR=ICR+1
. . S PXPCEARR("IMM CONTRA/REFUSAL",ICR,"CONTRA/REFUSAL")=CODE
. . I $P(X,U,5)'="" S PXPCEARR("IMM CONTRA/REFUSAL",ICR,"IMMUN")=+$$TRIM^XLFSTR($P(X,U,5))
. . I $P(X,U,6)'="" S PXPCEARR("IMM CONTRA/REFUSAL",ICR,"WARN UNTIL DATE")=$$TRIM^XLFSTR($P(X,U,6))
. . I $P(X,U,7)'="" S PXPCEARR("IMM CONTRA/REFUSAL",ICR,"EVENT D/T")=$$TRIM^XLFSTR($P(X,U,7))
. . I $P(X,U,8)'="" S PXPCEARR("IMM CONTRA/REFUSAL",ICR,"ENC PROVIDER")=$$TRIM^XLFSTR($P(X,U,8))
. . I $P(X,U,9)'="" S PXPCEARR("IMM CONTRA/REFUSAL",ICR,"REFUSED VACCINE GROUP")=$$TRIM^XLFSTR($P(X,U,9))
. . S:$L($P(X,U,10))>0 COMMENT($P(X,U,10))="IMM CONTRA/REFUSAL^"_ICR
. . I $E(TYP,4)="-" S PXPCEARR("IMM CONTRA/REFUSAL",ICR,"DELETE")=1
. I $E(TYP,1,2)="SC" D Q
. . Q:'$L(CODE)
. . S SC=SC+1
. . S PXPCEARR("STD CODES",SC,"CODE")=CODE
. . I $P(X,U,5)'="" S PXPCEARR("STD CODES",SC,"CODING SYSTEM")=$P(X,U,5)
. . I $P(X,U,6)'="" S PXPCEARR("STD CODES",SC,"ENC PROVIDER")=$P(X,U,6)
. . I $P(X,U,7)'="" S PXPCEARR("STD CODES",SC,"MAGNITUDE")=$P(X,U,7)
. . I $P(X,U,8)'="" S PXPCEARR("STD CODES",SC,"UCUM CODE")=$P(X,U,8)
. . I $L($P(X,U,9)),($P(X,U,9)=1) S PXPCEARR("STD CODES",SC,"PL ADD")=$P(X,U,9) ;???,PROBLEMS(ICD)=NARR_U_CODE
. . I $P(X,U,10)'="" S COMMENT($P(X,U,10))="STD CODES^"_SC
. . I $P(X,U,11)'="" S PXPCEARR("STD CODES",SC,"EVENT D/T")=$P(X,U,11)
. . I $P(X,U,12)'="" S PXPCEARR("STD CODES",SC,"ORD PROVIDER")=$P(X,U,12)
. . I $E(TYP,3)="-" S PXPCEARR("STD CODES",SC,"DELETE")=1
. I $E(TYP,1,3)="COM" D Q
. . Q:'$L(CODE)
. . Q:'$L(CAT)
. . S COMMENTS(CODE)=$$CTRL^XMXUTIL1($P(X,U,3)) ; Strip control characters when filing comments
;
;Store the comments
S COM=""
;F S COM=$O(COMMENT(COM)) Q:COM="" S:$D(COMMENTS(COM)) PXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
F S COM=$O(COMMENT(COM)) Q:COM="" D:$D(COMMENTS(COM))
. I $G(IMMCOMMS(COM))'="" D
. . I COMMENTS(COM)="@" S COMMENTS(COM)=""
. . S COMMENTS(COM)=COMMENTS(COM)_$S(COMMENTS(COM)="":"",1:" ")_IMMCOMMS(COM)
. S PXPCEARR($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
;
;Store the Remarks (currently used by immunizations) - PX,210
S COM=""
F S COM=$O(REMARK(COM)) Q:COM="" I $D(COMMENTS(COM)) D
. S TYP=$P(REMARK(COM),"^",1)
. S NUM=$P(REMARK(COM),"^",2)
. S SEQ=$O(PXPCEARR(TYP,NUM,"REMARKS",""),-1)+1
. S PXPCEARR(TYP,NUM,"REMARKS",SEQ,0)=COMMENTS(COM)
;
;Store the Immunization Override Reason - PX,215
S COM=""
F S COM=$O(IMMOVERRIDE(COM)) Q:COM="" I $G(COMMENTS(COM))'="" D
. S TYP=$P(IMMOVERRIDE(COM),"^",1)
. S NUM=$P(IMMOVERRIDE(COM),"^",2)
. S PXPCEARR(TYP,NUM,"OVERRIDE REASON")=COMMENTS(COM)
;
;Store the Skin Test Reading Comment - PX*1*216
S COM=""
F S COM=$O(SKRDCOM(COM)) Q:COM="" I $G(COMMENTS(COM))'="" D
. S TYP=$P(SKRDCOM(COM),"^",1)
. S NUM=$P(SKRDCOM(COM),"^",2)
. S PXPCEARR(TYP,NUM,"READING COMMENT")=COMMENTS(COM)
;
;Store the Immunization Reading Comment (for smallpox)
S COM=""
F S COM=$O(IMMRDCOM(COM)) Q:COM="" I $G(COMMENTS(COM))'="" D
. S TYP=$P(IMMRDCOM(COM),"^",1)
. S NUM=$P(IMMRDCOM(COM),"^",2)
. S PXPCEIMMRD(TYP,NUM,"READING COMMENT")=COMMENTS(COM)
;
I $D(PXPCEARR("ENCOUNTER",1)),$G(PXPCEARR("ENCOUNTER",1,"ENCOUNTER TYPE"))="" D
. S PXPCEARR("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRPC1 14381 printed Jul 11, 2026@02:26:55 Page 2
PXRPC1 ;ISL/JLC,GN - PCE DATA2PCE RPC Cont ;Aug 04, 2025@08:51:23
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**217,244**;Aug 12, 1996;Build 37
+2 ;
+3 ; References to ICDEX supported by ICR #5747
+4 ;
DQSAVE(PCELIST,PXPCEARR,PROBLEMS,SRC,PXPCEIMMRD) ;
+1 ;
+2 ; Called from DQSAVE^PXRPC
+3 ;
+4 NEW TYP,CODE,IEN,I,X
+5 NEW CAT,NARR,PXENCDT
+6 NEW PRV,CPT,ICD,IMM,SC,SK,PED,HF,XAM,TRT,ICR,MOD,MODCNT,MODIDX,MODS
+7 NEW COM,COMMENT,COMMENTS,SVCAT
+8 NEW DFN,PXAPREDT
+9 ; Vars for Info Source (IMMIS) Imm. Admin Route (IMMRT), Body Site (IMMAL), Lot, Manufacturer, Exp. Date & Comments
+10 NEW IMMISNM,IMMISIEN,IMMRTNM,IMMRTIEN,IMMRTERR,IMMALNAME,IMMALIEN,IMMALERR,IMMLOT,IMMMANUF,IMMEXPDT,IMMCOMM,IMMCOMMS,IMMLOTIEN
+11 NEW NUM,REMARK,SEQ,IMMDSG,IMMCVX,IMMCVXER,IMMOVERRIDE,IMMRDCOM,SKRDCOM,PXVIMM
+12 SET (PRV,CPT,ICD,IMM,SC,SK,PED,HF,XAM,TRT,ICR)=0
+13 SET I=""
FOR
SET I=$ORDER(PCELIST(I))
if 'I
QUIT
SET X=PCELIST(I)
Begin DoDot:1
+14 SET X=PCELIST(I)
SET TYP=$PIECE(X,U)
SET CODE=$PIECE(X,U,2)
SET CAT=$PIECE(X,U,3)
SET NARR=$PIECE(X,U,4)
+15 IF $EXTRACT(TYP,1,3)="PRV"
Begin DoDot:2
+16 if '$LENGTH(CODE)
QUIT
+17 SET PRV=PRV+1
+18 ;Set the flag to allow editing of primary provider
SET PXAPREDT=1
+19 SET PXPCEARR("PROVIDER",PRV,"NAME")=CODE
+20 SET PXPCEARR("PROVIDER",PRV,"PRIMARY")=$PIECE(X,U,6)
+21 IF $EXTRACT(TYP,4)="-"
SET PXPCEARR("PROVIDER",PRV,"DELETE")=1
End DoDot:2
QUIT
+22 IF TYP="VST"
Begin DoDot:2
+23 IF CODE="DT"
SET (PXENCDT,PXPCEARR("ENCOUNTER",1,"ENC D/T"))=$PIECE(X,U,3)
QUIT
+24 IF CODE="PT"
SET PXPCEARR("ENCOUNTER",1,"PATIENT")=$PIECE(X,U,3)
SET DFN=$PIECE(X,U,3)
QUIT
+25 IF CODE="HL"
SET PXPCEARR("ENCOUNTER",1,"HOS LOC")=$PIECE(X,U,3)
QUIT
+26 IF CODE="PR"
SET PXPCEARR("ENCOUNTER",1,"PARENT")=$PIECE(X,U,3)
QUIT
+27 IF CODE="ET"
SET PXPCEARR("ENCOUNTER",1,"ENCOUNTER TYPE")=$PIECE(X,U,3)
QUIT
+28 ;prevents checkout!
+29 IF CODE="VC"
SET (SVCAT,PXPCEARR("ENCOUNTER",1,"SERVICE CATEGORY"))=$PIECE(X,U,3)
QUIT
+30 IF CODE="OL"
Begin DoDot:3
+31 IF +$PIECE(X,U,3)
SET PXPCEARR("ENCOUNTER",1,"INSTITUTION")=$PIECE(X,U,3)
+32 IF '$TEST
IF $PIECE(X,U,4)'=""
IF $PIECE(X,U,4)'="0"
SET PXPCEARR("ENCOUNTER",1,"OUTSIDE LOCATION")=$PIECE(X,U,4)
End DoDot:3
QUIT
+33 IF $$FINDBYCODE^PXSPECAUTH(CODE)
SET PXPCEARR("ENCOUNTER",1,CODE)=$PIECE(X,U,3)
QUIT
End DoDot:2
QUIT
+34 IF $EXTRACT(TYP,1,3)="CPT"
Begin DoDot:2
+35 if '$LENGTH(CODE)
QUIT
+36 SET CPT=CPT+1
+37 ;ICR #1995
SET IEN=$$CODEN^ICPTCOD(CODE)
+38 SET PXPCEARR("PROCEDURE",CPT,"PROCEDURE")=IEN
+39 IF +$PIECE(X,U,9)
Begin DoDot:3
+40 SET MODS=$PIECE(X,U,9)
SET MODCNT=+MODS
+41 FOR MODIDX=1:1:MODCNT
Begin DoDot:4
+42 SET MOD=$PIECE($PIECE(MODS,";",MODIDX+1),"/")
+43 SET PXPCEARR("PROCEDURE",CPT,"MODIFIERS",MOD)=""
End DoDot:4
End DoDot:3
+44 if $LENGTH(CAT)
SET PXPCEARR("PROCEDURE",CPT,"CATEGORY")=CAT
+45 if $LENGTH(NARR)
SET PXPCEARR("PROCEDURE",CPT,"NARRATIVE")=NARR
+46 if $LENGTH($PIECE(X,U,5))
SET PXPCEARR("PROCEDURE",CPT,"QTY")=$PIECE(X,U,5)
+47 if $PIECE(X,U,6)>0
SET PXPCEARR("PROCEDURE",CPT,"ENC PROVIDER")=$PIECE(X,U,6)
+48 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="PROCEDURE^"_CPT
+49 IF $EXTRACT(TYP,4)="-"
SET PXPCEARR("PROCEDURE",CPT,"DELETE")=1
SET PXPCEARR("PROCEDURE",CPT,"QTY")=0
End DoDot:2
QUIT
+50 IF $EXTRACT(TYP,1,3)="POV"
Begin DoDot:2
+51 NEW PXDXI,PXDX
+52 if '$LENGTH(CODE)
QUIT
+53 FOR PXDXI=1:1:$LENGTH(CODE,"/")
Begin DoDot:3
+54 NEW CSYS,CDT,IEN,LEXIEN
+55 SET PXDX=$PIECE(CODE,"/",PXDXI)
+56 SET ICD=ICD+1
+57 IF (PXDX]"")
IF (PXDX'[".")
SET PXDX=PXDX_"."
+58 SET IEN=$PIECE($$CODEN^ICDEX(PXDX,80),"~",1)
+59 IF IEN'>0
QUIT
+60 SET PXPCEARR("DX/PL",ICD,"DIAGNOSIS")=IEN
+61 SET PXPCEARR("DX/PL",ICD,"PRIMARY")=$SELECT(PXDXI=1:$PIECE(X,U,5),1:0)
+62 SET CDT=$SELECT($GET(SVCAT)="E":DT,1:$GET(PXENCDT))
+63 SET CSYS=$$CSI^ICDEX(80,IEN)
+64 SET LEXIEN=$PIECE($$EXP^LEXCODE(PXDX,CSYS,CDT),U)
SET PXPCEARR("DX/PL",ICD,"LEXICON TERM")=$SELECT(LEXIEN>0:LEXIEN,1:"")
+65 if $LENGTH(CAT)
SET PXPCEARR("DX/PL",ICD,"CATEGORY")=CAT
+66 if $LENGTH(NARR)
SET PXPCEARR("DX/PL",ICD,"NARRATIVE")=NARR
+67 if $PIECE(X,U,6)>0
SET PXPCEARR("DX/PL",ICD,"ENC PROVIDER")=$PIECE(X,U,6)
+68 IF $LENGTH($PIECE(X,U,7))
IF ($PIECE(X,U,7)=1)
IF (PXDXI=1)
SET PXPCEARR("DX/PL",ICD,"PL ADD")=$PIECE(X,U,7)
SET PROBLEMS(ICD)=NARR_U_CODE
+69 if $LENGTH($PIECE(X,U,10))>0&(PXDXI=1)
SET COMMENT($PIECE(X,U,10))="DX/PL^"_ICD
+70 IF $EXTRACT(TYP,4)="-"
SET PXPCEARR("DX/PL",ICD,"DELETE")=1
End DoDot:3
End DoDot:2
QUIT
+71 IF $EXTRACT(TYP,1,3)="IMM"
Begin DoDot:2
+72 ; If the CVX Code is present, then use it to find the corresponding Immunization,
+73 ; but only if the Immunization IEN is not specified
+74 SET IMMCVX=$PIECE(X,U,11)
+75 IF CODE=""
IF IMMCVX'=""
Begin DoDot:3
+76 DO CVXTOIEN^PXAPIIM(.CODE,IMMCVX)
+77 SET CODE=$PIECE(CODE,U,1)
End DoDot:3
+78 if '$LENGTH(CODE)
QUIT
+79 ;
+80 ; if this is for a smallpox reading, file this as an update against the original
+81 ; Visit/V Immunization entry.
+82 ; (Piece 30 is for the V Immunization IEN. It should only be populated when doing
+83 ; a reading).
+84 SET PXVIMM=$PIECE(X,U,30)
+85 IF PXVIMM
Begin DoDot:3
+86 IF '$DATA(^AUPNVIMM(PXVIMM,0))
Begin DoDot:4
+87 SET PXPCEIMMRD("IMMUNIZATION",1,"ERROR")="V Immunization IEN (#"_PXVIMM_") does not exist. Cannot save reading."
End DoDot:4
QUIT
+88 IF $GET(DFN)
IF DFN'=$PIECE($GET(^AUPNVIMM(PXVIMM,0)),U,2)
Begin DoDot:4
+89 SET PXPCEIMMRD("IMMUNIZATION",1,"ERROR")="Patient IEN does not match previous V Immunization entry (#"_PXVIMM_"). Cannot save reading."
End DoDot:4
QUIT
+90 SET PXPCEIMMRD("IMMUNIZATION",1,"VISIT")=$PIECE($GET(^AUPNVIMM(PXVIMM,0)),U,3)
+91 SET PXPCEIMMRD("IMMUNIZATION",1,"IMMUN")=CODE
+92 ; Reading fields (for smallpox)
+93 if $PIECE(X,U,25)'=""
SET PXPCEIMMRD("IMMUNIZATION",1,"RESULT")=$PIECE(X,U,25)
+94 if $PIECE(X,U,26)'=""
SET PXPCEIMMRD("IMMUNIZATION",1,"READING")=$PIECE(X,U,26)
+95 if $PIECE(X,U,27)'=""
SET PXPCEIMMRD("IMMUNIZATION",1,"D/T READ")=$PIECE(X,U,27)
+96 if $PIECE(X,U,28)>0
SET PXPCEIMMRD("IMMUNIZATION",1,"READER")=$PIECE(X,U,28)
+97 IF $PIECE(X,U,29)>0
SET IMMRDCOM($PIECE(X,U,29))="IMMUNIZATION^1"
End DoDot:3
QUIT
+98 ;
+99 SET IMM=IMM+1
+100 SET PXPCEARR("IMMUNIZATION",IMM,"IMMUN")=CODE
+101 IF IMMCVX'=""
SET PXPCEARR("IMMUNIZATION",IMM,"CVX")=IMMCVX
+102 if $LENGTH($PIECE(X,U,5))
SET PXPCEARR("IMMUNIZATION",IMM,"SERIES")=$PIECE(X,U,5)
+103 if $LENGTH($PIECE(X,U,7))
SET PXPCEARR("IMMUNIZATION",IMM,"REACTION")=$PIECE(X,U,7)
+104 if $LENGTH($PIECE(X,U,8))
SET PXPCEARR("IMMUNIZATION",IMM,"CONTRAINDICATED")=$PIECE(X,U,8)
+105 if $LENGTH($PIECE(X,U,9))
SET PXPCEARR("IMMUNIZATION",IMM,"REFUSED")=$PIECE(X,U,9)
+106 if $PIECE(X,U,6)>0
SET PXPCEARR("IMMUNIZATION",IMM,"ENC PROVIDER")=$PIECE(X,U,6)
+107 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="IMMUNIZATION^"_IMM
+108 ; These are the additional fields being added by PX*1.0*209
+109 SET IMMISIEN=$$IMMSRC^PXRPC($PIECE(X,U,12))
+110 if IMMISIEN
SET PXPCEARR("IMMUNIZATION",IMM,"INFO SOURCE")=IMMISIEN
+111 SET IMMRTIEN=$$IMMROUTE^PXRPC($PIECE(X,U,14))
+112 if IMMRTIEN
SET PXPCEARR("IMMUNIZATION",IMM,"ADMIN ROUTE")=IMMRTIEN
+113 SET IMMALIEN=$$IMMLOC^PXRPC($PIECE(X,U,15))
+114 if IMMALIEN'=""
SET PXPCEARR("IMMUNIZATION",IMM,"ANATOMIC LOC")=IMMALIEN
+115 SET IMMLOT=$$IMMLOT^PXRPC($PIECE(X,U,16),$PIECE(X,U,17),$PIECE(X,U,18))
+116 SET IMMLOTIEN=$PIECE(IMMLOT,"^",1)
+117 SET IMMCOMM=$PIECE(IMMLOT,"^",2)
+118 if IMMLOTIEN
SET PXPCEARR("IMMUNIZATION",IMM,"LOT NUM")=IMMLOTIEN
+119 SET IMMDSG=$$IMMDSG^PXRPC($PIECE(X,U,13))
+120 IF $PIECE(IMMDSG,U,1)'=""
Begin DoDot:3
+121 SET PXPCEARR("IMMUNIZATION",IMM,"DOSE")=$PIECE(IMMDSG,U,1)
+122 IF $PIECE(IMMDSG,U,2)
SET PXPCEARR("IMMUNIZATION",IMM,"DOSE UNITS")=$PIECE(IMMDSG,U,2)
End DoDot:3
+123 ; add Dosage to comments
IF $PIECE(IMMDSG,U,3)'=""
Begin DoDot:3
+124 SET IMMCOMM=$SELECT($GET(IMMCOMM)'="":IMMCOMM_"; ",1:"")_$PIECE(IMMDSG,U,3)
End DoDot:3
+125 IF IMMCOMM'=""
Begin DoDot:3
+126 ; If we have something to add to the Imm comment, either add it to the existing comment
+127 ; (if one exists) or just set it in the COMMENT field.
+128 ; This will get added later to the existing comment
IF $LENGTH($PIECE(X,U,10))
SET IMMCOMMS($PIECE(X,U,10))=IMMCOMM
+129 IF '$TEST
SET PXPCEARR("IMMUNIZATION",IMM,"COMMENT")=IMMCOMM
End DoDot:3
+130 if $PIECE(X,U,19)>0
SET PXPCEARR("IMMUNIZATION",IMM,"EVENT D/T")=$PIECE(X,U,19)
+131 IF $PIECE(X,U,20)'=""
SET PXPCEARR("IMMUNIZATION",IMM,"ORD PROVIDER")=$PIECE(X,U,20)
+132 IF $PIECE(X,U,21)'=""
DO IMMVIS^PXRPC($PIECE(X,U,21),.PXPCEARR,IMM)
+133 IF $PIECE(X,U,22)'=""
DO IMMRMRKS^PXRPC($PIECE(X,U,22),IMM,.REMARK)
+134 IF $PIECE(X,U,23)'=""
SET PXPCEARR("IMMUNIZATION",IMM,"WARNING ACK")=$PIECE(X,U,23)
+135 IF $PIECE(X,U,24)>0
SET IMMOVERRIDE($PIECE(X,U,24))="IMMUNIZATION^"_IMM
+136 IF $PIECE(X,U,31)'=""
SET PXPCEARR("IMMUNIZATION",IMM,"ORD BY POLICY")=$PIECE(X,U,31)
+137 IF $EXTRACT(TYP,4)="-"
SET PXPCEARR("IMMUNIZATION",IMM,"DELETE")=1
End DoDot:2
QUIT
+138 IF $EXTRACT(TYP,1,2)="SK"
Begin DoDot:2
+139 if '$LENGTH(CODE)
QUIT
+140 SET SK=SK+1
+141 SET PXPCEARR("SKIN TEST",SK,"TEST")=CODE
+142 if $LENGTH($PIECE(X,U,5))
SET PXPCEARR("SKIN TEST",SK,"RESULT")=$PIECE(X,U,5)
+143 if $PIECE(X,U,6)>0
SET PXPCEARR("SKIN TEST",SK,"ENC PROVIDER")=$PIECE(X,U,6)
+144 if $LENGTH($PIECE(X,U,7))
SET PXPCEARR("SKIN TEST",SK,"READING")=$PIECE(X,U,7)
+145 if $LENGTH($PIECE(X,U,8))
SET PXPCEARR("SKIN TEST",SK,"D/T READ")=$PIECE(X,U,8)
+146 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="SKIN TEST^"_SK
+147 if $PIECE(X,U,11)>0
SET PXPCEARR("SKIN TEST",SK,"READER")=$PIECE(X,U,11)
+148 IF $PIECE(X,U,14)>0
SET SKRDCOM($PIECE(X,U,14))="SKIN TEST^"_SK
+149 SET IMMALIEN=$$IMMLOC^PXRPC($PIECE(X,U,15))
+150 if IMMALIEN
SET PXPCEARR("SKIN TEST",SK,"ANATOMIC LOC")=IMMALIEN
+151 IF $PIECE(X,U,16)>0
SET PXPCEARR("SKIN TEST",SK,"PLACEMENT")=$PIECE(X,U,16)
+152 if $LENGTH($PIECE(X,U,19))
SET PXPCEARR("SKIN TEST",SK,"EVENT D/T")=$PIECE(X,U,19)
+153 if $PIECE(X,U,20)>0
SET PXPCEARR("SKIN TEST",SK,"ORD PROVIDER")=$PIECE(X,U,20)
+154 IF $EXTRACT(TYP,3)="-"
SET PXPCEARR("SKIN TEST",SK,"DELETE")=1
End DoDot:2
QUIT
+155 IF $EXTRACT(TYP,1,3)="PED"
Begin DoDot:2
+156 if '$LENGTH(CODE)
QUIT
+157 SET PED=PED+1
+158 SET PXPCEARR("PATIENT ED",PED,"TOPIC")=CODE
+159 if $LENGTH($PIECE(X,U,5))
SET PXPCEARR("PATIENT ED",PED,"UNDERSTANDING")=$PIECE(X,U,5)
+160 if $PIECE(X,U,6)>0
SET PXPCEARR("PATIENT ED",PED,"ENC PROVIDER")=$PIECE(X,U,6)
+161 IF $PIECE(X,U,7)'=""
SET PXPCEARR("PATIENT ED",PED,"MAGNITUDE")=$PIECE(X,U,7)
+162 IF $PIECE(X,U,8)'=""
SET PXPCEARR("PATIENT ED",PED,"UCUM CODE")=$PIECE(X,U,8)
+163 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="PATIENT ED^"_PED
+164 IF $EXTRACT(TYP,4)="-"
SET PXPCEARR("PATIENT ED",PED,"DELETE")=1
End DoDot:2
QUIT
+165 IF $EXTRACT(TYP,1,2)="HF"
Begin DoDot:2
+166 if '$LENGTH(CODE)
QUIT
+167 SET HF=HF+1
+168 SET PXPCEARR("HEALTH FACTOR",HF,"HEALTH FACTOR")=CODE
+169 if $LENGTH($PIECE(X,U,5))
SET PXPCEARR("HEALTH FACTOR",HF,"LEVEL/SEVERITY")=$PIECE(X,U,5)
+170 if $PIECE(X,U,6)'>0
SET $PIECE(X,U,6)=$GET(PXPCEARR("PROVIDER",1,"NAME"))
+171 if $PIECE(X,U,6)>0
SET PXPCEARR("HEALTH FACTOR",HF,"ENC PROVIDER")=$PIECE(X,U,6)
+172 IF $PIECE(X,U,7)'=""
SET PXPCEARR("HEALTH FACTOR",HF,"MAGNITUDE")=$PIECE(X,U,7)
+173 IF $PIECE(X,U,8)'=""
SET PXPCEARR("HEALTH FACTOR",HF,"UCUM CODE")=$PIECE(X,U,8)
+174 if $LENGTH($PIECE(X,U,11))
SET PXPCEARR("HEALTH FACTOR",HF,"EVENT D/T")=$PIECE($PIECE(X,U,11),";",1)
+175 if $LENGTH($PIECE(X,U,11))
SET SRC=$PIECE($PIECE(X,U,11),";",2)
+176 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="HEALTH FACTOR^"_HF
+177 IF $EXTRACT(TYP,3)="-"
SET PXPCEARR("HEALTH FACTOR",HF,"DELETE")=1
End DoDot:2
QUIT
+178 IF $EXTRACT(TYP,1,3)="XAM"
Begin DoDot:2
+179 if '$LENGTH(CODE)
QUIT
+180 SET XAM=XAM+1
+181 SET PXPCEARR("EXAM",XAM,"EXAM")=CODE
+182 if $LENGTH($PIECE(X,U,5))
SET PXPCEARR("EXAM",XAM,"RESULT")=$PIECE(X,U,5)
+183 if $PIECE(X,U,6)>0
SET PXPCEARR("EXAM",XAM,"ENC PROVIDER")=$PIECE(X,U,6)
+184 IF $PIECE(X,U,7)'=""
SET PXPCEARR("EXAM",XAM,"MAGNITUDE")=$PIECE(X,U,7)
+185 IF $PIECE(X,U,8)'=""
SET PXPCEARR("EXAM",XAM,"UCUM CODE")=$PIECE(X,U,8)
+186 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="EXAM^"_XAM
+187 IF $EXTRACT(TYP,4)="-"
SET PXPCEARR("EXAM",XAM,"DELETE")=1
End DoDot:2
QUIT
+188 IF $EXTRACT(TYP,1,3)="TRT"
Begin DoDot:2
+189 if '$LENGTH(CODE)
QUIT
+190 SET TRT=TRT+1
+191 SET PXPCEARR("TREATMENT",TRT,"IMMUN")=CODE
+192 if $LENGTH(CAT)
SET PXPCEARR("TREATMENT",TRT,"CATEGORY")=CAT
+193 if $LENGTH(NARR)
SET PXPCEARR("TREATMENT",TRT,"NARRATIVE")=NARR
+194 if $LENGTH($PIECE(X,U,5))
SET PXPCEARR("TREATMENT",TRT,"QTY")=$PIECE(X,U,5)
+195 if $PIECE(X,U,6)>0
SET PXPCEARR("TREATMENT",TRT,"ENC PROVIDER")=$PIECE(X,U,6)
+196 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="TREATMENT^"_TRT
+197 IF $EXTRACT(TYP,4)="-"
SET PXPCEARR("TREATMENT",TRT,"DELETE")=1
SET PXPCEARR("TREATMENT",TRT,"QTY")=0
End DoDot:2
QUIT
+198 IF $EXTRACT(TYP,1,3)="ICR"
Begin DoDot:2
+199 if '$LENGTH(CODE)
QUIT
+200 SET ICR=ICR+1
+201 SET PXPCEARR("IMM CONTRA/REFUSAL",ICR,"CONTRA/REFUSAL")=CODE
+202 IF $PIECE(X,U,5)'=""
SET PXPCEARR("IMM CONTRA/REFUSAL",ICR,"IMMUN")=+$$TRIM^XLFSTR($PIECE(X,U,5))
+203 IF $PIECE(X,U,6)'=""
SET PXPCEARR("IMM CONTRA/REFUSAL",ICR,"WARN UNTIL DATE")=$$TRIM^XLFSTR($PIECE(X,U,6))
+204 IF $PIECE(X,U,7)'=""
SET PXPCEARR("IMM CONTRA/REFUSAL",ICR,"EVENT D/T")=$$TRIM^XLFSTR($PIECE(X,U,7))
+205 IF $PIECE(X,U,8)'=""
SET PXPCEARR("IMM CONTRA/REFUSAL",ICR,"ENC PROVIDER")=$$TRIM^XLFSTR($PIECE(X,U,8))
+206 IF $PIECE(X,U,9)'=""
SET PXPCEARR("IMM CONTRA/REFUSAL",ICR,"REFUSED VACCINE GROUP")=$$TRIM^XLFSTR($PIECE(X,U,9))
+207 if $LENGTH($PIECE(X,U,10))>0
SET COMMENT($PIECE(X,U,10))="IMM CONTRA/REFUSAL^"_ICR
+208 IF $EXTRACT(TYP,4)="-"
SET PXPCEARR("IMM CONTRA/REFUSAL",ICR,"DELETE")=1
End DoDot:2
QUIT
+209 IF $EXTRACT(TYP,1,2)="SC"
Begin DoDot:2
+210 if '$LENGTH(CODE)
QUIT
+211 SET SC=SC+1
+212 SET PXPCEARR("STD CODES",SC,"CODE")=CODE
+213 IF $PIECE(X,U,5)'=""
SET PXPCEARR("STD CODES",SC,"CODING SYSTEM")=$PIECE(X,U,5)
+214 IF $PIECE(X,U,6)'=""
SET PXPCEARR("STD CODES",SC,"ENC PROVIDER")=$PIECE(X,U,6)
+215 IF $PIECE(X,U,7)'=""
SET PXPCEARR("STD CODES",SC,"MAGNITUDE")=$PIECE(X,U,7)
+216 IF $PIECE(X,U,8)'=""
SET PXPCEARR("STD CODES",SC,"UCUM CODE")=$PIECE(X,U,8)
+217 ;???,PROBLEMS(ICD)=NARR_U_CODE
IF $LENGTH($PIECE(X,U,9))
IF ($PIECE(X,U,9)=1)
SET PXPCEARR("STD CODES",SC,"PL ADD")=$PIECE(X,U,9)
+218 IF $PIECE(X,U,10)'=""
SET COMMENT($PIECE(X,U,10))="STD CODES^"_SC
+219 IF $PIECE(X,U,11)'=""
SET PXPCEARR("STD CODES",SC,"EVENT D/T")=$PIECE(X,U,11)
+220 IF $PIECE(X,U,12)'=""
SET PXPCEARR("STD CODES",SC,"ORD PROVIDER")=$PIECE(X,U,12)
+221 IF $EXTRACT(TYP,3)="-"
SET PXPCEARR("STD CODES",SC,"DELETE")=1
End DoDot:2
QUIT
+222 IF $EXTRACT(TYP,1,3)="COM"
Begin DoDot:2
+223 if '$LENGTH(CODE)
QUIT
+224 if '$LENGTH(CAT)
QUIT
+225 ; Strip control characters when filing comments
SET COMMENTS(CODE)=$$CTRL^XMXUTIL1($PIECE(X,U,3))
End DoDot:2
QUIT
End DoDot:1
+226 ;
+227 ;Store the comments
+228 SET COM=""
+229 ;F S COM=$O(COMMENT(COM)) Q:COM="" S:$D(COMMENTS(COM)) PXAPI($P(COMMENT(COM),"^",1),$P(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
+230 FOR
SET COM=$ORDER(COMMENT(COM))
if COM=""
QUIT
if $DATA(COMMENTS(COM))
Begin DoDot:1
+231 IF $GET(IMMCOMMS(COM))'=""
Begin DoDot:2
+232 IF COMMENTS(COM)="@"
SET COMMENTS(COM)=""
+233 SET COMMENTS(COM)=COMMENTS(COM)_$SELECT(COMMENTS(COM)="":"",1:" ")_IMMCOMMS(COM)
End DoDot:2
+234 SET PXPCEARR($PIECE(COMMENT(COM),"^",1),$PIECE(COMMENT(COM),"^",2),"COMMENT")=COMMENTS(COM)
End DoDot:1
+235 ;
+236 ;Store the Remarks (currently used by immunizations) - PX,210
+237 SET COM=""
+238 FOR
SET COM=$ORDER(REMARK(COM))
if COM=""
QUIT
IF $DATA(COMMENTS(COM))
Begin DoDot:1
+239 SET TYP=$PIECE(REMARK(COM),"^",1)
+240 SET NUM=$PIECE(REMARK(COM),"^",2)
+241 SET SEQ=$ORDER(PXPCEARR(TYP,NUM,"REMARKS",""),-1)+1
+242 SET PXPCEARR(TYP,NUM,"REMARKS",SEQ,0)=COMMENTS(COM)
End DoDot:1
+243 ;
+244 ;Store the Immunization Override Reason - PX,215
+245 SET COM=""
+246 FOR
SET COM=$ORDER(IMMOVERRIDE(COM))
if COM=""
QUIT
IF $GET(COMMENTS(COM))'=""
Begin DoDot:1
+247 SET TYP=$PIECE(IMMOVERRIDE(COM),"^",1)
+248 SET NUM=$PIECE(IMMOVERRIDE(COM),"^",2)
+249 SET PXPCEARR(TYP,NUM,"OVERRIDE REASON")=COMMENTS(COM)
End DoDot:1
+250 ;
+251 ;Store the Skin Test Reading Comment - PX*1*216
+252 SET COM=""
+253 FOR
SET COM=$ORDER(SKRDCOM(COM))
if COM=""
QUIT
IF $GET(COMMENTS(COM))'=""
Begin DoDot:1
+254 SET TYP=$PIECE(SKRDCOM(COM),"^",1)
+255 SET NUM=$PIECE(SKRDCOM(COM),"^",2)
+256 SET PXPCEARR(TYP,NUM,"READING COMMENT")=COMMENTS(COM)
End DoDot:1
+257 ;
+258 ;Store the Immunization Reading Comment (for smallpox)
+259 SET COM=""
+260 FOR
SET COM=$ORDER(IMMRDCOM(COM))
if COM=""
QUIT
IF $GET(COMMENTS(COM))'=""
Begin DoDot:1
+261 SET TYP=$PIECE(IMMRDCOM(COM),"^",1)
+262 SET NUM=$PIECE(IMMRDCOM(COM),"^",2)
+263 SET PXPCEIMMRD(TYP,NUM,"READING COMMENT")=COMMENTS(COM)
End DoDot:1
+264 ;
+265 IF $DATA(PXPCEARR("ENCOUNTER",1))
IF $GET(PXPCEARR("ENCOUNTER",1,"ENCOUNTER TYPE"))=""
Begin DoDot:1
+266 SET PXPCEARR("ENCOUNTER",1,"ENCOUNTER TYPE")="P"
End DoDot:1
+267 ;
+268 QUIT
