- PXRHS02 ;ISL/SBW - PCE Visit data extract subroutines ;8-Nov-96
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**13,73,121**;Aug 12, 1996
- GETREC(PXA,PXCAT,EXTRCODE,IEXDT,PXCNT) ; Get rec and load ^TMP("PXHSV",$J,
- N DIC,DIQ,DR,DA,REC,VISIT,TYPE,LOC,SERCAT,CHKOUT,CLINIC,WALKAPT,EMCODE,ELIG
- N HLOC,HLOCABB,OLOC
- S DIC=9000010,DA=PXA,DIQ="REC(",DIQ(0)="IE"
- ;--fix for fields .16 and .17 that were removed from file
- ; and .18 should alway be blank
- S DR=".01;.03;.06;.07;.08;.09;.11;.21;.22;2101"
- D EN^DIQ1
- Q:'$D(REC)
- Q:$G(PXCAT)'[REC(9000010,DA,.07,"I")!(REC(9000010,DA,.09,"I")'>0)!+(REC(9000010,DA,.11,"I"))
- S VISIT=REC(9000010,DA,.01,"I")
- S:+$G(IEXDT)'>0 IEXDT=9999999-VISIT
- S TYPE=REC(9000010,DA,.03,"E")
- S LOC=REC(9000010,DA,.06,"E")
- S SERCAT=REC(9000010,DA,.07,"E")
- S CLINIC=REC(9000010,DA,.08,"E")
- ;--fields .16 and .17 are not in file
- S WALKAPT="" ;REC(9000010,DA,.16,"E")
- S EMCODE="" ;REC(9000010,DA,.17,"E")
- ;--field .18 does not have data more that very short term
- S CHKOUT="" ;REC(9000010,DA,.18,"I")
- S ELIG=REC(9000010,DA,.21,"E")
- S HLOC=REC(9000010,DA,.22,"E")
- S HLOCABB=$$GETHLOC^PXRHS02(REC(9000010,DA,.22,"I"))
- S OLOC=REC(9000010,DA,2101,"E")
- S PXCNT=PXCNT+1
- S ^TMP("PXHSV",$J,IEXDT,PXCNT,0)=VISIT_U_TYPE_U_LOC_U_SERCAT_U_CHKOUT_U_HLOC_U_HLOCABB_U_OLOC_U_CLINIC_U_WALKAPT_U_EMCODE_U_ELIG
- D:$G(EXTRCODE)["C" GETCPT^PXRHS02(PXA,IEXDT,PXCNT)
- D:$G(EXTRCODE)["D" GETPOV^PXRHS02(PXA,IEXDT,PXCNT)
- D:$G(EXTRCODE)["P" GETPROV^PXRHS02(PXA,IEXDT,PXCNT)
- Q
- GETHLOC(PXHLOC) ; Get hospital location abbreviation
- Q $P($G(^SC(+PXHLOC,0)),U,2)
- GETCPT(PXVDF,IDT,CNT) ; Get Procedures performed during the visit
- Q:$O(^AUPNVCPT("AD",PXVDF,""))=""
- N PXPDN,COMMENT
- S PXPDN=""
- F S PXPDN=$O(^AUPNVCPT("AD",PXVDF,PXPDN)) Q:'PXPDN D
- . N DIC,DIQ,DR,DA,REC,CPT,NARR,QTY,PRIM,SUBIEN,MOD
- . S DIC=9000010.18,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
- . S DR=".01;.04;.07;.16;81101"
- . D EN^DIQ1
- . Q:'$D(REC)
- . S CPT=REC(9000010.18,DA,.01,"I")
- . S NARR=REC(9000010.18,DA,.04,"E")
- . S QTY=REC(9000010.18,DA,.16,"E")
- . S PRIM=REC(9000010.18,DA,.07,"I")
- . S COMMENT=REC(9000010.18,DA,81101,"E")
- . S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN)=CPT_U_NARR_U_QTY_U_PRIM
- . S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN,"COM")=COMMENT
- . ;get modifiers
- . K REC D CPTMODIF^PXAAVCPT(PXPDN,.REC)
- . ;set modifiers
- . Q:'$D(REC)
- . S SUBIEN=""
- . F S SUBIEN=$O(REC(1,SUBIEN)) Q:SUBIEN="" D
- .. S MOD=$G(REC(1,SUBIEN,.01))
- .. I MOD'="" S MOD=$$MOD^ICPTMOD(MOD,"I",IDT)
- .. I $P(MOD,"^")<0 Q
- .. S ^TMP("PXHSV",$J,IDT,CNT,"C",PXPDN,$P(MOD,"^",2))=""
- Q
- GETPOV(PXVDF,IDT,CNT) ; Get Purpose of visit
- Q:$O(^AUPNVPOV("AD",PXVDF,""))=""
- N PXPDN,COMMENT
- S PXPDN=""
- F S PXPDN=$O(^AUPNVPOV("AD",PXVDF,PXPDN)) Q:'PXPDN D
- . N DIC,DIQ,DR,DA,REC,POV,NARR,MOD,CAUSE,PLACE,PRIM
- . S DIC=9000010.07,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
- . S DR=".01;.04;.06;.12;81101"
- . D EN^DIQ1
- . Q:'$D(REC)
- . S POV=REC(9000010.07,DA,.01,"I")
- . S NARR=REC(9000010.07,DA,.04,"E")
- . S MOD=REC(9000010.07,DA,.06,"E")
- . S CAUSE="" ;REC(9000010.07,DA,.07,"E")
- . S PLACE="" ;REC(9000010.07,DA,.11,"E")
- . S PRIM=REC(9000010.07,DA,.12,"E")
- . S COMMENT=REC(9000010.07,DA,81101,"E")
- . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN)=POV_U_MOD_U_CAUSE_U_PLACE_U_PRIM
- . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN,"N")=NARR
- . S ^TMP("PXHSV",$J,IDT,CNT,"D",PXPDN,"COM")=COMMENT
- Q
- GETPROV(PXVDF,IDT,CNT) ;Entry point to get providers for a visits
- I $O(^AUPNVPRV("AD",PXVDF,""))="" Q
- S PXPDN=""
- F S PXPDN=$O(^AUPNVPRV("AD",PXVDF,PXPDN)) Q:'PXPDN D
- . N DIC,DIQ,DR,DA,REC,PROV,PRIM,IPRIM
- . S DIC=9000010.06,DA=PXPDN,DIQ="REC(",DIQ(0)="IE"
- . S DR=".01;.04"
- . D EN^DIQ1
- . Q:'$D(REC)
- . S PROV=REC(9000010.06,DA,.01,"E")
- . S PRIM=REC(9000010.06,DA,.04,"E")
- . S IPRIM=REC(9000010.06,DA,.04,"I")
- . S:IPRIM="" IPRIM="Z"
- . S ^TMP("PXHSV",$J,IDT,CNT,"P",IPRIM,PXPDN)=PROV_U_PRIM
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRHS02 3923 printed Feb 18, 2025@23:56:40 Page 2
- PXRHS02 ;ISL/SBW - PCE Visit data extract subroutines ;8-Nov-96
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**13,73,121**;Aug 12, 1996
- GETREC(PXA,PXCAT,EXTRCODE,IEXDT,PXCNT) ; Get rec and load ^TMP("PXHSV",$J,
- +1 NEW DIC,DIQ,DR,DA,REC,VISIT,TYPE,LOC,SERCAT,CHKOUT,CLINIC,WALKAPT,EMCODE,ELIG
- +2 NEW HLOC,HLOCABB,OLOC
- +3 SET DIC=9000010
- SET DA=PXA
- SET DIQ="REC("
- SET DIQ(0)="IE"
- +4 ;--fix for fields .16 and .17 that were removed from file
- +5 ; and .18 should alway be blank
- +6 SET DR=".01;.03;.06;.07;.08;.09;.11;.21;.22;2101"
- +7 DO EN^DIQ1
- +8 if '$DATA(REC)
- QUIT
- +9 if $GET(PXCAT)'[REC(9000010,DA,.07,"I")!(REC(9000010,DA,.09,"I")'>0)!+(REC(9000010,DA,.11,"I"))
- QUIT
- +10 SET VISIT=REC(9000010,DA,.01,"I")
- +11 if +$GET(IEXDT)'>0
- SET IEXDT=9999999-VISIT
- +12 SET TYPE=REC(9000010,DA,.03,"E")
- +13 SET LOC=REC(9000010,DA,.06,"E")
- +14 SET SERCAT=REC(9000010,DA,.07,"E")
- +15 SET CLINIC=REC(9000010,DA,.08,"E")
- +16 ;--fields .16 and .17 are not in file
- +17 ;REC(9000010,DA,.16,"E")
- SET WALKAPT=""
- +18 ;REC(9000010,DA,.17,"E")
- SET EMCODE=""
- +19 ;--field .18 does not have data more that very short term
- +20 ;REC(9000010,DA,.18,"I")
- SET CHKOUT=""
- +21 SET ELIG=REC(9000010,DA,.21,"E")
- +22 SET HLOC=REC(9000010,DA,.22,"E")
- +23 SET HLOCABB=$$GETHLOC^PXRHS02(REC(9000010,DA,.22,"I"))
- +24 SET OLOC=REC(9000010,DA,2101,"E")
- +25 SET PXCNT=PXCNT+1
- +26 SET ^TMP("PXHSV",$JOB,IEXDT,PXCNT,0)=VISIT_U_TYPE_U_LOC_U_SERCAT_U_CHKOUT_U_HLOC_U_HLOCABB_U_OLOC_U_CLINIC_U_WALKAPT_U_EMCODE_U_ELIG
- +27 if $GET(EXTRCODE)["C"
- DO GETCPT^PXRHS02(PXA,IEXDT,PXCNT)
- +28 if $GET(EXTRCODE)["D"
- DO GETPOV^PXRHS02(PXA,IEXDT,PXCNT)
- +29 if $GET(EXTRCODE)["P"
- DO GETPROV^PXRHS02(PXA,IEXDT,PXCNT)
- +30 QUIT
- GETHLOC(PXHLOC) ; Get hospital location abbreviation
- +1 QUIT $PIECE($GET(^SC(+PXHLOC,0)),U,2)
- GETCPT(PXVDF,IDT,CNT) ; Get Procedures performed during the visit
- +1 if $ORDER(^AUPNVCPT("AD",PXVDF,""))=""
- QUIT
- +2 NEW PXPDN,COMMENT
- +3 SET PXPDN=""
- +4 FOR
- SET PXPDN=$ORDER(^AUPNVCPT("AD",PXVDF,PXPDN))
- if 'PXPDN
- QUIT
- Begin DoDot:1
- +5 NEW DIC,DIQ,DR,DA,REC,CPT,NARR,QTY,PRIM,SUBIEN,MOD
- +6 SET DIC=9000010.18
- SET DA=PXPDN
- SET DIQ="REC("
- SET DIQ(0)="IE"
- +7 SET DR=".01;.04;.07;.16;81101"
- +8 DO EN^DIQ1
- +9 if '$DATA(REC)
- QUIT
- +10 SET CPT=REC(9000010.18,DA,.01,"I")
- +11 SET NARR=REC(9000010.18,DA,.04,"E")
- +12 SET QTY=REC(9000010.18,DA,.16,"E")
- +13 SET PRIM=REC(9000010.18,DA,.07,"I")
- +14 SET COMMENT=REC(9000010.18,DA,81101,"E")
- +15 SET ^TMP("PXHSV",$JOB,IDT,CNT,"C",PXPDN)=CPT_U_NARR_U_QTY_U_PRIM
- +16 SET ^TMP("PXHSV",$JOB,IDT,CNT,"C",PXPDN,"COM")=COMMENT
- +17 ;get modifiers
- +18 KILL REC
- DO CPTMODIF^PXAAVCPT(PXPDN,.REC)
- +19 ;set modifiers
- +20 if '$DATA(REC)
- QUIT
- +21 SET SUBIEN=""
- +22 FOR
- SET SUBIEN=$ORDER(REC(1,SUBIEN))
- if SUBIEN=""
- QUIT
- Begin DoDot:2
- +23 SET MOD=$GET(REC(1,SUBIEN,.01))
- +24 IF MOD'=""
- SET MOD=$$MOD^ICPTMOD(MOD,"I",IDT)
- +25 IF $PIECE(MOD,"^")<0
- QUIT
- +26 SET ^TMP("PXHSV",$JOB,IDT,CNT,"C",PXPDN,$PIECE(MOD,"^",2))=""
- End DoDot:2
- End DoDot:1
- +27 QUIT
- GETPOV(PXVDF,IDT,CNT) ; Get Purpose of visit
- +1 if $ORDER(^AUPNVPOV("AD",PXVDF,""))=""
- QUIT
- +2 NEW PXPDN,COMMENT
- +3 SET PXPDN=""
- +4 FOR
- SET PXPDN=$ORDER(^AUPNVPOV("AD",PXVDF,PXPDN))
- if 'PXPDN
- QUIT
- Begin DoDot:1
- +5 NEW DIC,DIQ,DR,DA,REC,POV,NARR,MOD,CAUSE,PLACE,PRIM
- +6 SET DIC=9000010.07
- SET DA=PXPDN
- SET DIQ="REC("
- SET DIQ(0)="IE"
- +7 SET DR=".01;.04;.06;.12;81101"
- +8 DO EN^DIQ1
- +9 if '$DATA(REC)
- QUIT
- +10 SET POV=REC(9000010.07,DA,.01,"I")
- +11 SET NARR=REC(9000010.07,DA,.04,"E")
- +12 SET MOD=REC(9000010.07,DA,.06,"E")
- +13 ;REC(9000010.07,DA,.07,"E")
- SET CAUSE=""
- +14 ;REC(9000010.07,DA,.11,"E")
- SET PLACE=""
- +15 SET PRIM=REC(9000010.07,DA,.12,"E")
- +16 SET COMMENT=REC(9000010.07,DA,81101,"E")
- +17 SET ^TMP("PXHSV",$JOB,IDT,CNT,"D",PXPDN)=POV_U_MOD_U_CAUSE_U_PLACE_U_PRIM
- +18 SET ^TMP("PXHSV",$JOB,IDT,CNT,"D",PXPDN,"N")=NARR
- +19 SET ^TMP("PXHSV",$JOB,IDT,CNT,"D",PXPDN,"COM")=COMMENT
- End DoDot:1
- +20 QUIT
- GETPROV(PXVDF,IDT,CNT) ;Entry point to get providers for a visits
- +1 IF $ORDER(^AUPNVPRV("AD",PXVDF,""))=""
- QUIT
- +2 SET PXPDN=""
- +3 FOR
- SET PXPDN=$ORDER(^AUPNVPRV("AD",PXVDF,PXPDN))
- if 'PXPDN
- QUIT
- Begin DoDot:1
- +4 NEW DIC,DIQ,DR,DA,REC,PROV,PRIM,IPRIM
- +5 SET DIC=9000010.06
- SET DA=PXPDN
- SET DIQ="REC("
- SET DIQ(0)="IE"
- +6 SET DR=".01;.04"
- +7 DO EN^DIQ1
- +8 if '$DATA(REC)
- QUIT
- +9 SET PROV=REC(9000010.06,DA,.01,"E")
- +10 SET PRIM=REC(9000010.06,DA,.04,"E")
- +11 SET IPRIM=REC(9000010.06,DA,.04,"I")
- +12 if IPRIM=""
- SET IPRIM="Z"
- +13 SET ^TMP("PXHSV",$JOB,IDT,CNT,"P",IPRIM,PXPDN)=PROV_U_PRIM
- End DoDot:1
- +14 QUIT