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