- PXSCH4 ;ISL/JVS,SCK - SCHEDULING REDESIGN PROCEDURES-DIAG #4 ;6/11/96
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**194,199**;Aug 12, 1996;Build 51
- ; Variable List
- ;
- ; DXN800 "PXK" global data for various nodes
- ; DXN802 ""
- ; DXNOD0 ""
- ; DXNOD12 ""
- ; PXSDX The Main Diagnosis
- ; PXSINDX Index for "PXK" global
- ; PXSPR The main provider
- ;
- DIAG ;Create nodes for diagnosis
- Q:'$D(PXS("DIAGNOSIS"))
- S PXSDX=0 F S PXSDX=$O(PXS("DIAGNOSIS",PXSDX)) Q:PXSDX="" D
- .S PXSINDX=PXSINDX+1
- .D DXNOD
- Q
- DXNOD ;
- S DXNOD0="",$P(DXNOD0,"^")=+$G(PXS("DIAGNOSIS",PXSDX))
- S $P(DXNOD0,"^",2)=$G(PXS("PATIENT")) ;PROVIDER
- S $P(DXNOD0,"^",3)=$G(PXS("VISIT")) ;VISIT
- N ICDDATA,PXSDATE
- S PXSDATE=$$CSDATE^PXDXUTL($G(PXS("VISIT")))
- S PXSFILE=9000010.07
- S ICDDATA=$$ICDDATA^ICDXCODE("DIAG",PXSDX,PXSDATE,"E")
- S PXSZPN=$P(ICDDATA,U,4)
- S $P(DXNOD0,"^",4)=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE)
- Q:$P(DXNOD0,"^",4)=-1
- S DXNOD12=""
- ;S $P(DXNOD12,"^")=$G(PXS("DATE")) ;DATE AND TIME
- ;S $P(DXNOD12,"^",3)=$G(PXS("STOP CODE ORIG")) ;CLINIC STOP
- ;S $P(DXNOD12,"^",4)=$G(PXSPR) ;PROVIDER
- ;S $P(DXNOD12,"^",5)=$G(PXS("CLINIC")) ;HOSPITAL LOCATION
- ;S $P(DXNOD12,"^",7)=$P(DXNOD0,"^",3) ;SECONDARY VISIT
- S DXN800=""
- I $D(PXS("CLASSIFICATION",1)) S $P(DXN800,"^",2)=1
- I $D(PXS("CLASSIFICATION",2)) S $P(DXN800,"^",3)=1
- I $D(PXS("CLASSIFICATION",3)) S $P(DXN800,"^",1)=1
- I $D(PXS("CLASSIFICATION",4)) S $P(DXN800,"^",4)=1
- N PXS1
- S PXS1=$P(ICDDATA,U,6)
- S PXSZPN=$$GET1^DIQ(80.3,PXS1,.01)
- ;--DECIDED TO REMOVE CATEGORY
- ;K ^UTILITY("DIQ1",$J)
- ;S $P(DXN802,"^",1)=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE)
- ;I $P(DXN802,"^",1)'>0 S $P(DXN802,"^",1)=""
- S ^TMP("PXK",$J,"POV",PXSINDX+1,0,"AFTER")=$G(DXNOD0)
- S ^TMP("PXK",$J,"POV",PXSINDX+1,0,"BEFORE")=""
- S ^TMP("PXK",$J,"POV",PXSINDX+1,12,"AFTER")=$G(DXNOD12)
- S ^TMP("PXK",$J,"POV",PXSINDX+1,12,"BEFORE")=""
- S ^TMP("PXK",$J,"POV",PXSINDX+1,800,"AFTER")=$G(DXN800)
- S ^TMP("PXK",$J,"POV",PXSINDX+1,800,"BEFORE")=""
- S ^TMP("PXK",$J,"POV",PXSINDX+1,802,"AFTER")=""
- S ^TMP("PXK",$J,"POV",PXSINDX+1,802,"BEFORE")=""
- S ^TMP("PXK",$J,"POV",PXSINDX+1,"IEN")=""
- S ^TMP("PXK",$J,"SOR")=8
- S ^TMP("PXK",$J,"VST",1,"IEN")=$G(PXS("VISIT"))
- DXDUP ;Look for duplicates on the same visit
- N XPFG,XP
- S (XPFG,XP)=0
- F Q:XPFG S XP=$O(^AUPNVPOV("AD",PXS("VISIT"),XP)) Q:XP="" D
- .I $P(^AUPNVPOV(XP,0),"^",1)=+$G(PXS("DIAGNOSIS",PXSDX)) D
- ..S ^TMP("PXK",$J,"POV",PXSINDX+1,0,"BEFORE")=$G(^AUPNVPOV(XP,0))
- ..S ^TMP("PXK",$J,"POV",PXSINDX+1,12,"BEFORE")=$G(^AUPNVPOV(XP,12))
- ..S ^TMP("PXK",$J,"POV",PXSINDX+1,800,"BEFORE")=$G(^AUPNVPOV(XP,800))
- ..S ^TMP("PXK",$J,"POV",PXSINDX+1,802,"BEFORE")=+$G(^AUPNVPOV(XP,802))
- ..S ^TMP("PXK",$J,"POV",PXSINDX+1,"IEN")=XP
- ..S XPFG=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXSCH4 2787 printed Jan 18, 2025@03:32:25 Page 2
- PXSCH4 ;ISL/JVS,SCK - SCHEDULING REDESIGN PROCEDURES-DIAG #4 ;6/11/96
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**194,199**;Aug 12, 1996;Build 51
- +2 ; Variable List
- +3 ;
- +4 ; DXN800 "PXK" global data for various nodes
- +5 ; DXN802 ""
- +6 ; DXNOD0 ""
- +7 ; DXNOD12 ""
- +8 ; PXSDX The Main Diagnosis
- +9 ; PXSINDX Index for "PXK" global
- +10 ; PXSPR The main provider
- +11 ;
- DIAG ;Create nodes for diagnosis
- +1 if '$DATA(PXS("DIAGNOSIS"))
- QUIT
- +2 SET PXSDX=0
- FOR
- SET PXSDX=$ORDER(PXS("DIAGNOSIS",PXSDX))
- if PXSDX=""
- QUIT
- Begin DoDot:1
- +3 SET PXSINDX=PXSINDX+1
- +4 DO DXNOD
- End DoDot:1
- +5 QUIT
- DXNOD ;
- +1 SET DXNOD0=""
- SET $PIECE(DXNOD0,"^")=+$GET(PXS("DIAGNOSIS",PXSDX))
- +2 ;PROVIDER
- SET $PIECE(DXNOD0,"^",2)=$GET(PXS("PATIENT"))
- +3 ;VISIT
- SET $PIECE(DXNOD0,"^",3)=$GET(PXS("VISIT"))
- +4 NEW ICDDATA,PXSDATE
- +5 SET PXSDATE=$$CSDATE^PXDXUTL($GET(PXS("VISIT")))
- +6 SET PXSFILE=9000010.07
- +7 SET ICDDATA=$$ICDDATA^ICDXCODE("DIAG",PXSDX,PXSDATE,"E")
- +8 SET PXSZPN=$PIECE(ICDDATA,U,4)
- +9 SET $PIECE(DXNOD0,"^",4)=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE)
- +10 if $PIECE(DXNOD0,"^",4)=-1
- QUIT
- +11 SET DXNOD12=""
- +12 ;S $P(DXNOD12,"^")=$G(PXS("DATE")) ;DATE AND TIME
- +13 ;S $P(DXNOD12,"^",3)=$G(PXS("STOP CODE ORIG")) ;CLINIC STOP
- +14 ;S $P(DXNOD12,"^",4)=$G(PXSPR) ;PROVIDER
- +15 ;S $P(DXNOD12,"^",5)=$G(PXS("CLINIC")) ;HOSPITAL LOCATION
- +16 ;S $P(DXNOD12,"^",7)=$P(DXNOD0,"^",3) ;SECONDARY VISIT
- +17 SET DXN800=""
- +18 IF $DATA(PXS("CLASSIFICATION",1))
- SET $PIECE(DXN800,"^",2)=1
- +19 IF $DATA(PXS("CLASSIFICATION",2))
- SET $PIECE(DXN800,"^",3)=1
- +20 IF $DATA(PXS("CLASSIFICATION",3))
- SET $PIECE(DXN800,"^",1)=1
- +21 IF $DATA(PXS("CLASSIFICATION",4))
- SET $PIECE(DXN800,"^",4)=1
- +22 NEW PXS1
- +23 SET PXS1=$PIECE(ICDDATA,U,6)
- +24 SET PXSZPN=$$GET1^DIQ(80.3,PXS1,.01)
- +25 ;--DECIDED TO REMOVE CATEGORY
- +26 ;K ^UTILITY("DIQ1",$J)
- +27 ;S $P(DXN802,"^",1)=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE)
- +28 ;I $P(DXN802,"^",1)'>0 S $P(DXN802,"^",1)=""
- +29 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,0,"AFTER")=$GET(DXNOD0)
- +30 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,0,"BEFORE")=""
- +31 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,12,"AFTER")=$GET(DXNOD12)
- +32 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,12,"BEFORE")=""
- +33 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,800,"AFTER")=$GET(DXN800)
- +34 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,800,"BEFORE")=""
- +35 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,802,"AFTER")=""
- +36 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,802,"BEFORE")=""
- +37 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,"IEN")=""
- +38 SET ^TMP("PXK",$JOB,"SOR")=8
- +39 SET ^TMP("PXK",$JOB,"VST",1,"IEN")=$GET(PXS("VISIT"))
- DXDUP ;Look for duplicates on the same visit
- +1 NEW XPFG,XP
- +2 SET (XPFG,XP)=0
- +3 FOR
- if XPFG
- QUIT
- SET XP=$ORDER(^AUPNVPOV("AD",PXS("VISIT"),XP))
- if XP=""
- QUIT
- Begin DoDot:1
- +4 IF $PIECE(^AUPNVPOV(XP,0),"^",1)=+$GET(PXS("DIAGNOSIS",PXSDX))
- Begin DoDot:2
- +5 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,0,"BEFORE")=$GET(^AUPNVPOV(XP,0))
- +6 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,12,"BEFORE")=$GET(^AUPNVPOV(XP,12))
- +7 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,800,"BEFORE")=$GET(^AUPNVPOV(XP,800))
- +8 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,802,"BEFORE")=+$GET(^AUPNVPOV(XP,802))
- +9 SET ^TMP("PXK",$JOB,"POV",PXSINDX+1,"IEN")=XP
- +10 SET XPFG=1
- End DoDot:2
- End DoDot:1
- +11 QUIT