ORWPCE3 ; SLC/KCM - Get a PCE encounter for a TIU document;11/21/03
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,190**;Dec 17, 1997
Q
PCE4NOTE(LST,IEN,DFN,VSITSTR) ; Return encounter for an associated note
; LST(1)=HDR^AllowEdit^CPTRequired^VStr^Author^hasCPT
; LST(n)=TYP+^CODE^CAT^NARR^QUAL1^QUAL2 (QUAL1=Primary!Qty, QUAL2=Prv)
N VISIT,VSTR,ILST,LOC,CODE,PRIM,QTY,CAT,NARR,PRV,X0,X12,X802,X811,VTYP
N IPOV,ICPT,IPRV,IIMM,ISK,IPED,IHF,IXAM,ITRT,ICOM,MIDX,MIEN,MCNT,MODS
I +$G(IEN)<1 D I 1 ; Get PCE Data on a new note not yet saved
. S (X0,X12)=""
. S VISIT=$$GETENC^PXAPI(DFN,$P(VSITSTR,";",2),$P(VSITSTR,";"))
. S VSTR=VSITSTR
E D
. S X0=^TIU(8925,IEN,0),X12=$G(^(12))
. S VISIT=$P(X12,U,7)
. I 'VISIT S VISIT=$P(X0,U,3)
. D NOTEVSTR^ORWPCE(.VSTR,IEN)
S VTYP=$P(VSTR,";",3)
S ILST=1
S ICOM=0
S LST(1)="HDR"_U_("HID"[VTYP)_U_$P(X0,U,11)_U_VSTR_U_$P(X12,U,2)
;add hasCPT node
S LST(1)=LST(1)_U_0
I VISIT'>0 D Q
. I $G(VSTR)'="" M LST=^TMP("ORWPCE",$J,VSTR) ; get cached visit data
I $P(LST(1),U,2),VTYP="H" Q ; quit if admission
K ^TMP("PXKENC",$J)
D ENCEVENT^PXAPI(VISIT)
I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q
S $P(LST(1),U,6)=$D(^TMP("PXKENC",$J,VISIT,"CPT"))\10
S X0=^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),LOC=+$P(X0,U,22)
S ILST=ILST+1,LST(ILST)="VST^DT^"_$P(X0,U)
S ILST=ILST+1,LST(ILST)="VST^PT^"_$P(X0,U,5)
S ILST=ILST+1,LST(ILST)="VST^HL^"_LOC_"^^"_$P($G(^SC(LOC,0)),U)
S ILST=ILST+1,LST(ILST)="VST^PS^0" ;outpt
;S X0=$G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800))
N VAL
D SCSEL^ORWPCE(.VAL,$P(X0,U,5),$P(X0,U),LOC,VISIT)
S ILST=ILST+1,LST(ILST)="VST^SC^"_$P($P(VAL,";",1),U,2)
S ILST=ILST+1,LST(ILST)="VST^AO^"_$P($P(VAL,";",2),U,2)
S ILST=ILST+1,LST(ILST)="VST^IR^"_$P($P(VAL,";",3),U,2)
S ILST=ILST+1,LST(ILST)="VST^EC^"_$P($P(VAL,";",4),U,2)
S ILST=ILST+1,LST(ILST)="VST^MST^"_$P($P(VAL,";",5),U,2)
I $P(VAL,";",6)'="" D
.S ILST=ILST+1,LST(ILST)="VST^HNC^"_$P($P(VAL,";",6),U,2)
I $P(VAL,";",7)'="" D
.S ILST=ILST+1,LST(ILST)="VST^CV^"_$P($P(VAL,";",7),U,2)
;for provider
; LST(n)="PRV"^ien^^^name^primary/secondary flag
S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D
. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0)
. ;Q:$P(X0,U,4)'="P"
. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U)
. S PRIM=($P(X0,U,4)="P")
. S ILST=ILST+1
. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D
. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811))
. S CODE=$P(X0,U)
. S:CODE CODE=$P(^ICD9(CODE,0),U)
. S CAT=$P(X802,U)
. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
. S NARR=$P(X0,U,4)
. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
. S PRIM=($P(X0,U,12)="P")
. S PRV=$P(X12,U,4)
. S ILST=ILST+1
. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
. I X811]"" D
.. S ICOM=ICOM+1
.. S $P(LST(ILST),U,10)=ICOM
.. S ILST=ILST+1
.. S LST(ILST)="COM"_U_ICOM_U_X811
S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D
. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
. ;S CODE=$P(X0,U)
. S CODE=$O(^ICPT("B",$P(X0,U),0))
. S:CODE CODE=$P(^ICPT(CODE,0),U)
. S CAT=$P(X802,U)
. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
. S NARR=$P(X0,U,4)
. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
. S QTY=$P(X0,U,16)
. S PRV=$P(X12,U,4)
. S MCNT=0,MIDX=0,MODS=""
. F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D
. . S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0))
. . I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN
. I +MCNT S MODS=MCNT_MODS
. S ILST=ILST+1
. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
. I X811]"" D
.. S ICOM=ICOM+1
.. S $P(LST(ILST),U,10)=ICOM
.. S ILST=ILST+1
.. S LST(ILST)="COM"_U_ICOM_U_X811
;for immunization:
; LST(n)="IMM"^Code^^^Series^prv^Reaction^Contraindicated^Refused
S IIMM=0 F S IIMM=$O(^TMP("PXKENC",$J,VISIT,"IMM",IIMM)) Q:'IIMM D
. S X0=^TMP("PXKENC",$J,VISIT,"IMM",IIMM,0),X12=$G(^(12)),X811=$G(^(811))
. S CODE=$P(X0,U)
. S:CODE NARR=$P(^AUTTIMM(CODE,0),U)
. S QTY=$P(X0,U,4)
. S CAT=""
. S PRV=$P(X12,U,4)
. S ILST=ILST+1
. S LST(ILST)="IMM"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$P(X0,U,6,7)
. I X811]"" D
.. S ICOM=ICOM+1
.. S $P(LST(ILST),U,10)=ICOM
.. S ILST=ILST+1
.. S LST(ILST)="COM"_U_ICOM_U_X811
;for skin test:
; LST(n)="SK"^Code^^^result^prv^reading^d/t read^d/t given
S ISK=0 F S ISK=$O(^TMP("PXKENC",$J,VISIT,"SK",ISK)) Q:'ISK D
. S X0=^TMP("PXKENC",$J,VISIT,"SK",ISK,0),X12=$G(^(12)),X811=$G(^(811))
. S CODE=$P(X0,U)
. S:CODE NARR=$P(^AUTTSK(CODE,0),U)
. S QTY=$P(X0,U,4)
. S CAT=""
. S PRV=$P(X12,U,4)
. S ILST=ILST+1
. S LST(ILST)="SK"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$P(X0,U,5,6)_U_$P(X12,U)
. I X811]"" D
.. S ICOM=ICOM+1
.. S $P(LST(ILST),U,10)=ICOM
.. S ILST=ILST+1
.. S LST(ILST)="COM"_U_ICOM_U_X811
;for patient education:
; LST(n)="PED"^Code^^^level of understanding^prv
S IPED=0 F S IPED=$O(^TMP("PXKENC",$J,VISIT,"PED",IPED)) Q:'IPED D
. S X0=^TMP("PXKENC",$J,VISIT,"PED",IPED,0),X12=$G(^(12)),X811=$G(^(811))
. S CODE=$P(X0,U)
. S:CODE NARR=$P(^AUTTEDT(CODE,0),U)
. S QTY=$P(X0,U,6)
. S CAT=""
. S PRV=$P(X12,U,4)
. S ILST=ILST+1
. S LST(ILST)="PED"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
. I X811]"" D
.. S ICOM=ICOM+1
.. S $P(LST(ILST),U,10)=ICOM
.. S ILST=ILST+1
.. S LST(ILST)="COM"_U_ICOM_U_X811
;for health factors:
; LST(n)="HF"^Code^^^level/severity^prv
S IHF=0 F S IHF=$O(^TMP("PXKENC",$J,VISIT,"HF",IHF)) Q:'IHF D
. S X0=^TMP("PXKENC",$J,VISIT,"HF",IHF,0),X12=$G(^(12)),X811=$G(^(811))
. S CODE=$P(X0,U)
. S:CODE NARR=$P(^AUTTHF(CODE,0),U)
. S QTY=$P(X0,U,4)
. S CAT=""
. S PRV=$P(X12,U,4)
. S ILST=ILST+1
. S LST(ILST)="HF"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
. I X811]"" D
.. S ICOM=ICOM+1
.. S $P(LST(ILST),U,10)=ICOM
.. S ILST=ILST+1
.. S LST(ILST)="COM"_U_ICOM_U_X811
;for exam:
; LST(n)="XAM"^Code^^^result^prv
S IXAM=0 F S IXAM=$O(^TMP("PXKENC",$J,VISIT,"XAM",IXAM)) Q:'IXAM D
. S X0=^TMP("PXKENC",$J,VISIT,"XAM",IXAM,0),X12=$G(^(12)),X811=$G(^(811))
. S CODE=$P(X0,U)
. S:CODE NARR=$P(^AUTTEXAM(CODE,0),U)
. S QTY=$P(X0,U,4)
. S CAT=""
. S PRV=$P(X12,U,4)
. S ILST=ILST+1
. S LST(ILST)="XAM"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$P(X0,U,6,7)
. I X811]"" D
.. S ICOM=ICOM+1
.. S $P(LST(ILST),U,10)=ICOM
.. S ILST=ILST+1
.. S LST(ILST)="COM"_U_ICOM_U_X811
;for treatment:
; LST(n)="TRT"^Code^CAT^NARR^QTY^prv
S ITRT=0 F S ITRT=$O(^TMP("PXKENC",$J,VISIT,"TRT",ITRT)) Q:'ITRT D
. S X0=^TMP("PXKENC",$J,VISIT,"TRT",ITRT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
. S CODE=$P(X0,U)
. S QTY=$P(X0,U,4)
. S CAT=$P(X802,U)
. S NARR=$P(X0,U,6)
. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
. S PRV=$P(X12,U,4)
. S ILST=ILST+1
. S LST(ILST)="TRT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
. I X811]"" D
.. S ICOM=ICOM+1
.. S $P(LST(ILST),U,10)=ICOM
.. S ILST=ILST+1
.. S LST(ILST)="COM"_U_ICOM_U_X811
Q
ORWPCE3 ; SLC/KCM - Get a PCE encounter for a TIU document;11/21/03
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,190**;Dec 17, 1997
+2 QUIT
PCE4NOTE(LST,IEN,DFN,VSITSTR) ; Return encounter for an associated note
+1 ; LST(1)=HDR^AllowEdit^CPTRequired^VStr^Author^hasCPT
+2 ; LST(n)=TYP+^CODE^CAT^NARR^QUAL1^QUAL2 (QUAL1=Primary!Qty, QUAL2=Prv)
+3 NEW VISIT,VSTR,ILST,LOC,CODE,PRIM,QTY,CAT,NARR,PRV,X0,X12,X802,X811,VTYP
+4 NEW IPOV,ICPT,IPRV,IIMM,ISK,IPED,IHF,IXAM,ITRT,ICOM,MIDX,MIEN,MCNT,MODS
+5 ; Get PCE Data on a new note not yet saved
IF +$GET(IEN)<1
Begin DoDot:1
+6 SET (X0,X12)=""
+7 SET VISIT=$$GETENC^PXAPI(DFN,$PIECE(VSITSTR,";",2),$PIECE(VSITSTR,";"))
+8 SET VSTR=VSITSTR
End DoDot:1
IF 1
+9 IF '$TEST
Begin DoDot:1
+10 SET X0=^TIU(8925,IEN,0)
SET X12=$GET(^(12))
+11 SET VISIT=$PIECE(X12,U,7)
+12 IF 'VISIT
SET VISIT=$PIECE(X0,U,3)
+13 DO NOTEVSTR^ORWPCE(.VSTR,IEN)
End DoDot:1
+14 SET VTYP=$PIECE(VSTR,";",3)
+15 SET ILST=1
+16 SET ICOM=0
+17 SET LST(1)="HDR"_U_("HID"[VTYP)_U_$PIECE(X0,U,11)_U_VSTR_U_$PIECE(X12,U,2)
+18 ;add hasCPT node
+19 SET LST(1)=LST(1)_U_0
+20 IF VISIT'>0
Begin DoDot:1
+21 ; get cached visit data
IF $GET(VSTR)'=""
MERGE LST=^TMP("ORWPCE",$JOB,VSTR)
End DoDot:1
QUIT
+22 ; quit if admission
IF $PIECE(LST(1),U,2)
IF VTYP="H"
QUIT
+23 KILL ^TMP("PXKENC",$JOB)
+24 DO ENCEVENT^PXAPI(VISIT)
+25 IF '$DATA(^TMP("PXKENC",$JOB,VISIT,"VST",VISIT,0))
QUIT
+26 SET $PIECE(LST(1),U,6)=$DATA(^TMP("PXKENC",$JOB,VISIT,"CPT"))\10
+27 SET X0=^TMP("PXKENC",$JOB,VISIT,"VST",VISIT,0)
SET LOC=+$PIECE(X0,U,22)
+28 SET ILST=ILST+1
SET LST(ILST)="VST^DT^"_$PIECE(X0,U)
+29 SET ILST=ILST+1
SET LST(ILST)="VST^PT^"_$PIECE(X0,U,5)
+30 SET ILST=ILST+1
SET LST(ILST)="VST^HL^"_LOC_"^^"_$PIECE($GET(^SC(LOC,0)),U)
+31 ;outpt
SET ILST=ILST+1
SET LST(ILST)="VST^PS^0"
+32 ;S X0=$G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800))
+33 NEW VAL
+34 DO SCSEL^ORWPCE(.VAL,$PIECE(X0,U,5),$PIECE(X0,U),LOC,VISIT)
+35 SET ILST=ILST+1
SET LST(ILST)="VST^SC^"_$PIECE($PIECE(VAL,";",1),U,2)
+36 SET ILST=ILST+1
SET LST(ILST)="VST^AO^"_$PIECE($PIECE(VAL,";",2),U,2)
+37 SET ILST=ILST+1
SET LST(ILST)="VST^IR^"_$PIECE($PIECE(VAL,";",3),U,2)
+38 SET ILST=ILST+1
SET LST(ILST)="VST^EC^"_$PIECE($PIECE(VAL,";",4),U,2)
+39 SET ILST=ILST+1
SET LST(ILST)="VST^MST^"_$PIECE($PIECE(VAL,";",5),U,2)
+40 IF $PIECE(VAL,";",6)'=""
Begin DoDot:1
+41 SET ILST=ILST+1
SET LST(ILST)="VST^HNC^"_$PIECE($PIECE(VAL,";",6),U,2)
End DoDot:1
+42 IF $PIECE(VAL,";",7)'=""
Begin DoDot:1
+43 SET ILST=ILST+1
SET LST(ILST)="VST^CV^"_$PIECE($PIECE(VAL,";",7),U,2)
End DoDot:1
+44 ;for provider
+45 ; LST(n)="PRV"^ien^^^name^primary/secondary flag
+46 SET IPRV=0
FOR
SET IPRV=$ORDER(^TMP("PXKENC",$JOB,VISIT,"PRV",IPRV))
IF 'IPRV
QUIT
Begin DoDot:1
+47 SET X0=^TMP("PXKENC",$JOB,VISIT,"PRV",IPRV,0)
+48 ;Q:$P(X0,U,4)'="P"
+49 SET CODE=$PIECE(X0,U)
SET NARR=$PIECE($GET(^VA(200,CODE,0)),U)
+50 SET PRIM=($PIECE(X0,U,4)="P")
+51 SET ILST=ILST+1
+52 SET LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
End DoDot:1
+53 SET IPOV=0
FOR
SET IPOV=$ORDER(^TMP("PXKENC",$JOB,VISIT,"POV",IPOV))
IF 'IPOV
QUIT
Begin DoDot:1
+54 SET X0=^TMP("PXKENC",$JOB,VISIT,"POV",IPOV,0)
SET X802=$GET(^(802))
SET X811=$GET(^(811))
+55 SET CODE=$PIECE(X0,U)
+56 IF CODE
SET CODE=$PIECE(^ICD9(CODE,0),U)
+57 SET CAT=$PIECE(X802,U)
+58 IF CAT
SET CAT=$PIECE(^AUTNPOV(CAT,0),U)
+59 SET NARR=$PIECE(X0,U,4)
+60 IF NARR
SET NARR=$PIECE(^AUTNPOV(NARR,0),U)
+61 SET PRIM=($PIECE(X0,U,12)="P")
+62 SET PRV=$PIECE(X12,U,4)
+63 SET ILST=ILST+1
+64 SET LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
+65 IF X811]""
Begin DoDot:2
+66 SET ICOM=ICOM+1
+67 SET $PIECE(LST(ILST),U,10)=ICOM
+68 SET ILST=ILST+1
+69 SET LST(ILST)="COM"_U_ICOM_U_X811
End DoDot:2
End DoDot:1
+70 SET ICPT=0
FOR
SET ICPT=$ORDER(^TMP("PXKENC",$JOB,VISIT,"CPT",ICPT))
IF 'ICPT
QUIT
Begin DoDot:1
+71 SET X0=^TMP("PXKENC",$JOB,VISIT,"CPT",ICPT,0)
SET X802=$GET(^(802))
SET X12=$GET(^(12))
SET X811=$GET(^(811))
+72 ;S CODE=$P(X0,U)
+73 SET CODE=$ORDER(^ICPT("B",$PIECE(X0,U),0))
+74 IF CODE
SET CODE=$PIECE(^ICPT(CODE,0),U)
+75 SET CAT=$PIECE(X802,U)
+76 IF CAT
SET CAT=$PIECE(^AUTNPOV(CAT,0),U)
+77 SET NARR=$PIECE(X0,U,4)
+78 IF NARR
SET NARR=$PIECE(^AUTNPOV(NARR,0),U)
+79 SET QTY=$PIECE(X0,U,16)
+80 SET PRV=$PIECE(X12,U,4)
+81 SET MCNT=0
SET MIDX=0
SET MODS=""
+82 FOR
SET MIDX=$ORDER(^TMP("PXKENC",$JOB,VISIT,"CPT",ICPT,1,MIDX))
IF 'MIDX
QUIT
Begin DoDot:2
+83 SET MIEN=$GET(^TMP("PXKENC",$JOB,VISIT,"CPT",ICPT,1,MIDX,0))
+84 IF +MIEN
SET MCNT=MCNT+1
SET MODS=MODS_";/"_MIEN
End DoDot:2
+85 IF +MCNT
SET MODS=MCNT_MODS
+86 SET ILST=ILST+1
+87 SET LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
+88 IF X811]""
Begin DoDot:2
+89 SET ICOM=ICOM+1
+90 SET $PIECE(LST(ILST),U,10)=ICOM
+91 SET ILST=ILST+1
+92 SET LST(ILST)="COM"_U_ICOM_U_X811
End DoDot:2
End DoDot:1
+93 ;for immunization:
+94 ; LST(n)="IMM"^Code^^^Series^prv^Reaction^Contraindicated^Refused
+95 SET IIMM=0
FOR
SET IIMM=$ORDER(^TMP("PXKENC",$JOB,VISIT,"IMM",IIMM))
IF 'IIMM
QUIT
Begin DoDot:1
+96 SET X0=^TMP("PXKENC",$JOB,VISIT,"IMM",IIMM,0)
SET X12=$GET(^(12))
SET X811=$GET(^(811))
+97 SET CODE=$PIECE(X0,U)
+98 IF CODE
SET NARR=$PIECE(^AUTTIMM(CODE,0),U)
+99 SET QTY=$PIECE(X0,U,4)
+100 SET CAT=""
+101 SET PRV=$PIECE(X12,U,4)
+102 SET ILST=ILST+1
+103 SET LST(ILST)="IMM"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$PIECE(X0,U,6,7)
+104 IF X811]""
Begin DoDot:2
+105 SET ICOM=ICOM+1
+106 SET $PIECE(LST(ILST),U,10)=ICOM
+107 SET ILST=ILST+1
+108 SET LST(ILST)="COM"_U_ICOM_U_X811
End DoDot:2
End DoDot:1
+109 ;for skin test:
+110 ; LST(n)="SK"^Code^^^result^prv^reading^d/t read^d/t given
+111 SET ISK=0
FOR
SET ISK=$ORDER(^TMP("PXKENC",$JOB,VISIT,"SK",ISK))
IF 'ISK
QUIT
Begin DoDot:1
+112 SET X0=^TMP("PXKENC",$JOB,VISIT,"SK",ISK,0)
SET X12=$GET(^(12))
SET X811=$GET(^(811))
+113 SET CODE=$PIECE(X0,U)
+114 IF CODE
SET NARR=$PIECE(^AUTTSK(CODE,0),U)
+115 SET QTY=$PIECE(X0,U,4)
+116 SET CAT=""
+117 SET PRV=$PIECE(X12,U,4)
+118 SET ILST=ILST+1
+119 SET LST(ILST)="SK"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$PIECE(X0,U,5,6)_U_$PIECE(X12,U)
+120 IF X811]""
Begin DoDot:2
+121 SET ICOM=ICOM+1
+122 SET $PIECE(LST(ILST),U,10)=ICOM
+123 SET ILST=ILST+1
+124 SET LST(ILST)="COM"_U_ICOM_U_X811
End DoDot:2
End DoDot:1
+125 ;for patient education:
+126 ; LST(n)="PED"^Code^^^level of understanding^prv
+127 SET IPED=0
FOR
SET IPED=$ORDER(^TMP("PXKENC",$JOB,VISIT,"PED",IPED))
IF 'IPED
QUIT
Begin DoDot:1
+128 SET X0=^TMP("PXKENC",$JOB,VISIT,"PED",IPED,0)
SET X12=$GET(^(12))
SET X811=$GET(^(811))
+129 SET CODE=$PIECE(X0,U)
+130 IF CODE
SET NARR=$PIECE(^AUTTEDT(CODE,0),U)
+131 SET QTY=$PIECE(X0,U,6)
+132 SET CAT=""
+133 SET PRV=$PIECE(X12,U,4)
+134 SET ILST=ILST+1
+135 SET LST(ILST)="PED"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
+136 IF X811]""
Begin DoDot:2
+137 SET ICOM=ICOM+1
+138 SET $PIECE(LST(ILST),U,10)=ICOM
+139 SET ILST=ILST+1
+140 SET LST(ILST)="COM"_U_ICOM_U_X811
End DoDot:2
End DoDot:1
+141 ;for health factors:
+142 ; LST(n)="HF"^Code^^^level/severity^prv
+143 SET IHF=0
FOR
SET IHF=$ORDER(^TMP("PXKENC",$JOB,VISIT,"HF",IHF))
IF 'IHF
QUIT
Begin DoDot:1
+144 SET X0=^TMP("PXKENC",$JOB,VISIT,"HF",IHF,0)
SET X12=$GET(^(12))
SET X811=$GET(^(811))
+145 SET CODE=$PIECE(X0,U)
+146 IF CODE
SET NARR=$PIECE(^AUTTHF(CODE,0),U)
+147 SET QTY=$PIECE(X0,U,4)
+148 SET CAT=""
+149 SET PRV=$PIECE(X12,U,4)
+150 SET ILST=ILST+1
+151 SET LST(ILST)="HF"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
+152 IF X811]""
Begin DoDot:2
+153 SET ICOM=ICOM+1
+154 SET $PIECE(LST(ILST),U,10)=ICOM
+155 SET ILST=ILST+1
+156 SET LST(ILST)="COM"_U_ICOM_U_X811
End DoDot:2
End DoDot:1
+157 ;for exam:
+158 ; LST(n)="XAM"^Code^^^result^prv
+159 SET IXAM=0
FOR
SET IXAM=$ORDER(^TMP("PXKENC",$JOB,VISIT,"XAM",IXAM))
IF 'IXAM
QUIT
Begin DoDot:1
+160 SET X0=^TMP("PXKENC",$JOB,VISIT,"XAM",IXAM,0)
SET X12=$GET(^(12))
SET X811=$GET(^(811))
+161 SET CODE=$PIECE(X0,U)
+162 IF CODE
SET NARR=$PIECE(^AUTTEXAM(CODE,0),U)
+163 SET QTY=$PIECE(X0,U,4)
+164 SET CAT=""
+165 SET PRV=$PIECE(X12,U,4)
+166 SET ILST=ILST+1
+167 SET LST(ILST)="XAM"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_$PIECE(X0,U,6,7)
+168 IF X811]""
Begin DoDot:2
+169 SET ICOM=ICOM+1
+170 SET $PIECE(LST(ILST),U,10)=ICOM
+171 SET ILST=ILST+1
+172 SET LST(ILST)="COM"_U_ICOM_U_X811
End DoDot:2
End DoDot:1
+173 ;for treatment:
+174 ; LST(n)="TRT"^Code^CAT^NARR^QTY^prv
+175 SET ITRT=0
FOR
SET ITRT=$ORDER(^TMP("PXKENC",$JOB,VISIT,"TRT",ITRT))
IF 'ITRT
QUIT
Begin DoDot:1
+176 SET X0=^TMP("PXKENC",$JOB,VISIT,"TRT",ITRT,0)
SET X802=$GET(^(802))
SET X12=$GET(^(12))
SET X811=$GET(^(811))
+177 SET CODE=$PIECE(X0,U)
+178 SET QTY=$PIECE(X0,U,4)
+179 SET CAT=$PIECE(X802,U)
+180 SET NARR=$PIECE(X0,U,6)
+181 IF CAT
SET CAT=$PIECE(^AUTNPOV(CAT,0),U)
+182 IF NARR
SET NARR=$PIECE(^AUTNPOV(NARR,0),U)
+183 SET PRV=$PIECE(X12,U,4)
+184 SET ILST=ILST+1
+185 SET LST(ILST)="TRT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV
+186 IF X811]""
Begin DoDot:2
+187 SET ICOM=ICOM+1
+188 SET $PIECE(LST(ILST),U,10)=ICOM
+189 SET ILST=ILST+1
+190 SET LST(ILST)="COM"_U_ICOM_U_X811
End DoDot:2
End DoDot:1
+191 QUIT
