- PXBGPOV ;ISL/JVS,ESW - GATHER POV (DIAGNOSIS) ; 12/2/02 6:22pm
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112**;Aug 12, 1996
- ;
- POV(VISIT) ;--Gather the entries in the V POV file
- ;
- N IEN,QUANTITY,PROVIDER,SNARR,POV,GROUP,PXBC,POVI
- N DIC,DR,DA,DIQ,PRIM,PROBLEM,PXBPLA,PXBPL,PKG,SOURC
- ;
- K ^TMP("PXBU",$J),POV,PXBKY,PXBSAM,PXBSKY,PXDIGNS,NOPLLIST
- K ^UTILITY("DIQ1",$J)
- S FPRI="",PROBLEM=""
- I $D(^AUPNVPOV("AD",VISIT)) D
- .S IEN=0 F S IEN=$O(^AUPNVPOV("AD",VISIT,IEN)) Q:IEN'>0 D
- ..S ^TMP("PXBU",$J,"POV",IEN)=""
- ;
- A ;--Set array with DIAGNOSIS codes
- ;
- D PL^PXBGPL(PATIENT)
- I $D(^TMP("PXBU",$J,"POV")) D
- .S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"POV",IEN)) Q:IEN'>0 D
- ..S DIC=9000010.07,DR=".01;1204;.04;.12;81202;81203",DA=IEN,DIQ(0)="IE" D EN^DIQ1
- ..S PROVIDER=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"1204","E"))
- ..S LNARR=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".04","E"))
- ..S POV=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".01","E"))
- ..S PROBLEM="" S:$D(^TMP("PXBKYPL",$J,POV)) PROBLEM="YES"
- ..S POVI=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".01","I"))
- ..S PRIM=$G(^UTILITY("DIQ1",$J,9000010.07,DA,".12","E"))
- ..S PKG=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"81202","I"))
- ..I PKG']"" S PKG="NONE"
- ..S SOURC=$G(^UTILITY("DIQ1",$J,9000010.07,DA,"81203","I"))
- ..I SOURC']"" S SOURC="NONE"
- ..S SNARR=$$EXTTEXT^PXUTL1(POVI,1,80,3)
- ..I $L(LNARR)'>30 S LNARR=$$EXTTEXT^PXUTL1(POVI,1,80,10)
- ..S FPRI=FPRI_$E(PRIM,1,3) ;--Creating flag for Promary prompt
- ..S GROUP=POV_"^"_PROVIDER_"^"_SNARR_"^"_PRIM_"^"_PROBLEM
- ..; 1 2 3 4 5
- ..I PRIM["PRI" S PXDIGNS("PRIMARY")=POV
- ..S ^TMP("PXBPOV",$J,POV,IEN)=GROUP
- ..S ^TMP("PXBGPOVMATCH",$J,POVI,IEN)=""
- ..I $P(GROUP,"^",5)'["YES" S NOPLLIST=1
- ;
- B ;--Add line numbers
- ;
- I $D(^TMP("PXBPOV",$J)) D
- .S PXBC=0,POV="" F S POV=$O(^TMP("PXBPOV",$J,POV)) Q:POV="" Q:PXBC>40 D
- ..S IEN=0 F S IEN=$O(^TMP("PXBPOV",$J,POV,IEN)) Q:IEN="" S PXBC=PXBC+1 D
- ...S PXBKY(POV,PXBC)=$G(^TMP("PXBPOV",$J,POV,IEN)),PXBSAM(PXBC)=$G(^TMP("PXBPOV",$J,POV,IEN))
- ...S PXBSKY(PXBC,IEN)=""
- ...S PXBSAM(PXBC,"LNARR")=LNARR
- FINISG ;--finish up some variables
- ;--FPRI=0 NO PRIMARY
- S:FPRI'["PRI" FPRI=0 S:FPRI["PRI" FPRI=1
- EXIT ;--KILL
- K ^TMP("PXBU",$J),^TMP("PXBKYPL",$J),^TMP("PXBSAMPL",$J),PXBSKYPL
- K ^TMP("PXBPOV",$J)
- K ^UTILITY("DIQ1",$J)
- S PXBCNT=+$G(PXBC)
- Q
- ;
- PXBGPOV ;ISL/JVS,ESW - GATHER POV (DIAGNOSIS) ; 12/2/02 6:22pm
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112**;Aug 12, 1996
- +2 ;
- POV(VISIT) ;--Gather the entries in the V POV file
- +1 ;
- +2 NEW IEN,QUANTITY,PROVIDER,SNARR,POV,GROUP,PXBC,POVI
- +3 NEW DIC,DR,DA,DIQ,PRIM,PROBLEM,PXBPLA,PXBPL,PKG,SOURC
- +4 ;
- +5 KILL ^TMP("PXBU",$JOB),POV,PXBKY,PXBSAM,PXBSKY,PXDIGNS,NOPLLIST
- +6 KILL ^UTILITY("DIQ1",$JOB)
- +7 SET FPRI=""
- SET PROBLEM=""
- +8 IF $DATA(^AUPNVPOV("AD",VISIT))
- Begin DoDot:1
- +9 SET IEN=0
- FOR
- SET IEN=$ORDER(^AUPNVPOV("AD",VISIT,IEN))
- IF IEN'>0
- QUIT
- Begin DoDot:2
- +10 SET ^TMP("PXBU",$JOB,"POV",IEN)=""
- End DoDot:2
- End DoDot:1
- +11 ;
- A ;--Set array with DIAGNOSIS codes
- +1 ;
- +2 DO PL^PXBGPL(PATIENT)
- +3 IF $DATA(^TMP("PXBU",$JOB,"POV"))
- Begin DoDot:1
- +4 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXBU",$JOB,"POV",IEN))
- IF IEN'>0
- QUIT
- Begin DoDot:2
- +5 SET DIC=9000010.07
- SET DR=".01;1204;.04;.12;81202;81203"
- SET DA=IEN
- SET DIQ(0)="IE"
- DO EN^DIQ1
- +6 SET PROVIDER=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,"1204","E"))
- +7 SET LNARR=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".04","E"))
- +8 SET POV=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".01","E"))
- +9 SET PROBLEM=""
- IF $DATA(^TMP("PXBKYPL",$JOB,POV))
- SET PROBLEM="YES"
- +10 SET POVI=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".01","I"))
- +11 SET PRIM=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,".12","E"))
- +12 SET PKG=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,"81202","I"))
- +13 IF PKG']""
- SET PKG="NONE"
- +14 SET SOURC=$GET(^UTILITY("DIQ1",$JOB,9000010.07,DA,"81203","I"))
- +15 IF SOURC']""
- SET SOURC="NONE"
- +16 SET SNARR=$$EXTTEXT^PXUTL1(POVI,1,80,3)
- +17 IF $LENGTH(LNARR)'>30
- SET LNARR=$$EXTTEXT^PXUTL1(POVI,1,80,10)
- +18 ;--Creating flag for Promary prompt
- SET FPRI=FPRI_$EXTRACT(PRIM,1,3)
- +19 SET GROUP=POV_"^"_PROVIDER_"^"_SNARR_"^"_PRIM_"^"_PROBLEM
- +20 ; 1 2 3 4 5
- +21 IF PRIM["PRI"
- SET PXDIGNS("PRIMARY")=POV
- +22 SET ^TMP("PXBPOV",$JOB,POV,IEN)=GROUP
- +23 SET ^TMP("PXBGPOVMATCH",$JOB,POVI,IEN)=""
- +24 IF $PIECE(GROUP,"^",5)'["YES"
- SET NOPLLIST=1
- End DoDot:2
- End DoDot:1
- +25 ;
- B ;--Add line numbers
- +1 ;
- +2 IF $DATA(^TMP("PXBPOV",$JOB))
- Begin DoDot:1
- +3 SET PXBC=0
- SET POV=""
- FOR
- SET POV=$ORDER(^TMP("PXBPOV",$JOB,POV))
- IF POV=""
- QUIT
- IF PXBC>40
- QUIT
- Begin DoDot:2
- +4 SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP("PXBPOV",$JOB,POV,IEN))
- IF IEN=""
- QUIT
- SET PXBC=PXBC+1
- Begin DoDot:3
- +5 SET PXBKY(POV,PXBC)=$GET(^TMP("PXBPOV",$JOB,POV,IEN))
- SET PXBSAM(PXBC)=$GET(^TMP("PXBPOV",$JOB,POV,IEN))
- +6 SET PXBSKY(PXBC,IEN)=""
- +7 SET PXBSAM(PXBC,"LNARR")=LNARR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- FINISG ;--finish up some variables
- +1 ;--FPRI=0 NO PRIMARY
- +2 IF FPRI'["PRI"
- SET FPRI=0
- IF FPRI["PRI"
- SET FPRI=1
- EXIT ;--KILL
- +1 KILL ^TMP("PXBU",$JOB),^TMP("PXBKYPL",$JOB),^TMP("PXBSAMPL",$JOB),PXBSKYPL
- +2 KILL ^TMP("PXBPOV",$JOB)
- +3 KILL ^UTILITY("DIQ1",$JOB)
- +4 SET PXBCNT=+$GET(PXBC)
- +5 QUIT
- +6 ;
