PXSCH2 ;ISL/JVS,SCK - SCHEDULING REDESIGN PROCEDURES-CPT #2 ;7/25/96 09:12
;;1.0;PCE PATIENT CARE ENCOUNTER;**73,194**;Aug 12, 1996;Build 2
; Variable List
;
; CPTNOD0 The data for the ^TMP("PXK",$J, globals
; CPTNOD12 The data for the ^TMP("PXK",$J, globals
; CPTNOD8 The data for the ^TMP("PXK",$J, globals
; PXSCPT Pointer to the precedure being processed
; PXSCPTQ Quantity of the above procedure
; PXSDX The main Diagnosis
; PXSINDX Index for the "PXK" global
; PXSPNN resolved provider narrative
; PXSPNN(1) "" "" ""
; PXSPR The main Provider
; XP,XPFG Scratch Variables
;
SET ;Set the TMP("PXK",$J, GLOBAL
CPT ;Create nodes for Procedures
S PXSCPT=0 F S PXSCPT=$O(PXS("PROC",PXSCPT)) Q:PXSCPT="" D
.S PXSINDX=PXSINDX+1
.S PXSCPTQ=$G(PXS("PROC",PXSCPT))
.D CPTNOD
Q
CPTNOD ;
S CPTNOD0="",$P(CPTNOD0,"^")=$G(PXSCPT)
S $P(CPTNOD0,"^",2)=$G(PXS("PATIENT")) ;PATIENT
S $P(CPTNOD0,"^",3)=$G(PXS("VISIT")) ;VISIT
S PXSFILE=9000010.18
;K ^UTILITY("DIQ1",$J)
;S DIC=81,DA=PXSCPT,DR=2 D EN^DIQ1
;S PXSZPN=$G(^UTILITY("DIQ1",$J,81,DA,2))
;K ^UTILITY("DIQ1",$J),DIC,DA,DR
S PXSZPN=$P($$CPT^ICPTCOD(PXSCPT),U,3) ; px*2.0*194
S $P(CPTNOD0,"^",4)=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE) ;PROVIDER NARR
Q:$P(CPTNOD0,"^",4)=-1
;S $P(CPTNOD0,"^",5)=$G(PXSDX) ;DIAGNOSIS
S $P(CPTNOD0,"^",16)=$G(PXSCPTQ) ;QUANTITY
S CPTNOD12=""
;S $P(CPTNOD12,"^")=$G(PXS("DATE")) ;DATE AND TIME
;S $P(CPTNOD12,"^",3)=$G(PXS("STOP CODE ORIG")) ;CLINIC STOP
;S $P(CPTNOD12,"^",4)=$G(PXSPR) ;PROVIDER
;S $P(CPTNOD12,"^",5)=$G(PXS("CLINIC")) ;HOSPITAL LOCATION
;S $P(CPTNOD12,"^",7)=$P(CPTNOD0,"^",3) ;SECONDARY VISIT
;--DECIDED TO REMOVE THE CATEGORY
;S CPTNOD8=""
;K ^UTILITY("DIQ1",$J) S DIC=81,DA=PXSCPT,DR=3,DIQ(0)="EIN" D EN^DIQ1
;I $G(^UTILITY("DIQ1",$J,81,DA,3,"I")) D
;.S PXSZPN=$G(^UTILITY("DIQ1",$J,81,DA,3,"E"))
;.S CPTNOD8=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE)
;.I CPTNOD8'>0 S CPTNOD8=""
;K ^UTILITY("DIQ1",$J),DIC,DA,DR,DIQ
S ^TMP("PXK",$J,"CPT",PXSINDX+1,0,"AFTER")=$G(CPTNOD0)
S ^TMP("PXK",$J,"CPT",PXSINDX+1,0,"BEFORE")=""
S ^TMP("PXK",$J,"CPT",PXSINDX+1,1,1,"BEFORE")=""
S ^TMP("PXK",$J,"CPT",PXSINDX+1,12,"AFTER")=$G(CPTNOD12)
S ^TMP("PXK",$J,"CPT",PXSINDX+1,12,"BEFORE")=""
S ^TMP("PXK",$J,"CPT",PXSINDX+1,802,"AFTER")=""
S ^TMP("PXK",$J,"CPT",PXSINDX+1,802,"BEFORE")=""
S ^TMP("PXK",$J,"CPT",PXSINDX+1,"IEN")=""
S ^TMP("PXK",$J,"SOR")=8
S ^TMP("PXK",$J,"VST",1,"IEN")=$G(PXS("VISIT"))
CPTDUP ;Look for duplicates on the same visit
N XPFG,XP,PXKSEQ,PXKMOD
S (XPFG,XP)=0
F Q:XPFG S XP=$O(^AUPNVCPT("AD",PXS("VISIT"),XP)) Q:XP="" D
.I $P(^AUPNVCPT(XP,0),"^",1)=PXSCPT D
..S ^TMP("PXK",$J,"CPT",PXSINDX+1,0,"BEFORE")=$G(^AUPNVCPT(XP,0))
..S PXKSEQ=0
..F S PXKSEQ=$O(^AUPNVCPT(XP,1,PXKSEQ)) Q:'PXKSEQ D
...S PXKMOD=^AUPNVCPT(XP,1,PXKSEQ,0)
...S ^TMP("PXK",$J,"CPT",PXSINDX+1,1,PXKSEQ,"BEFORE")=PXKMOD
..S ^TMP("PXK",$J,"CPT",PXSINDX+1,12,"BEFORE")=$G(^AUPNVCPT(XP,12))
..S ^TMP("PXK",$J,"CPT",PXSINDX+1,802,"BEFORE")=+$G(^AUPNVCPT(XP,802))
..S ^TMP("PXK",$J,"CPT",PXSINDX+1,"IEN")=XP
..S XPFG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXSCH2 3170 printed Apr 09, 2024@21:32:30 Page 2
PXSCH2 ;ISL/JVS,SCK - SCHEDULING REDESIGN PROCEDURES-CPT #2 ;7/25/96 09:12
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**73,194**;Aug 12, 1996;Build 2
+2 ; Variable List
+3 ;
+4 ; CPTNOD0 The data for the ^TMP("PXK",$J, globals
+5 ; CPTNOD12 The data for the ^TMP("PXK",$J, globals
+6 ; CPTNOD8 The data for the ^TMP("PXK",$J, globals
+7 ; PXSCPT Pointer to the precedure being processed
+8 ; PXSCPTQ Quantity of the above procedure
+9 ; PXSDX The main Diagnosis
+10 ; PXSINDX Index for the "PXK" global
+11 ; PXSPNN resolved provider narrative
+12 ; PXSPNN(1) "" "" ""
+13 ; PXSPR The main Provider
+14 ; XP,XPFG Scratch Variables
+15 ;
SET ;Set the TMP("PXK",$J, GLOBAL
CPT ;Create nodes for Procedures
+1 SET PXSCPT=0
FOR
SET PXSCPT=$ORDER(PXS("PROC",PXSCPT))
if PXSCPT=""
QUIT
Begin DoDot:1
+2 SET PXSINDX=PXSINDX+1
+3 SET PXSCPTQ=$GET(PXS("PROC",PXSCPT))
+4 DO CPTNOD
End DoDot:1
+5 QUIT
CPTNOD ;
+1 SET CPTNOD0=""
SET $PIECE(CPTNOD0,"^")=$GET(PXSCPT)
+2 ;PATIENT
SET $PIECE(CPTNOD0,"^",2)=$GET(PXS("PATIENT"))
+3 ;VISIT
SET $PIECE(CPTNOD0,"^",3)=$GET(PXS("VISIT"))
+4 SET PXSFILE=9000010.18
+5 ;K ^UTILITY("DIQ1",$J)
+6 ;S DIC=81,DA=PXSCPT,DR=2 D EN^DIQ1
+7 ;S PXSZPN=$G(^UTILITY("DIQ1",$J,81,DA,2))
+8 ;K ^UTILITY("DIQ1",$J),DIC,DA,DR
+9 ; px*2.0*194
SET PXSZPN=$PIECE($$CPT^ICPTCOD(PXSCPT),U,3)
+10 ;PROVIDER NARR
SET $PIECE(CPTNOD0,"^",4)=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE)
+11 if $PIECE(CPTNOD0,"^",4)=-1
QUIT
+12 ;S $P(CPTNOD0,"^",5)=$G(PXSDX) ;DIAGNOSIS
+13 ;QUANTITY
SET $PIECE(CPTNOD0,"^",16)=$GET(PXSCPTQ)
+14 SET CPTNOD12=""
+15 ;S $P(CPTNOD12,"^")=$G(PXS("DATE")) ;DATE AND TIME
+16 ;S $P(CPTNOD12,"^",3)=$G(PXS("STOP CODE ORIG")) ;CLINIC STOP
+17 ;S $P(CPTNOD12,"^",4)=$G(PXSPR) ;PROVIDER
+18 ;S $P(CPTNOD12,"^",5)=$G(PXS("CLINIC")) ;HOSPITAL LOCATION
+19 ;S $P(CPTNOD12,"^",7)=$P(CPTNOD0,"^",3) ;SECONDARY VISIT
+20 ;--DECIDED TO REMOVE THE CATEGORY
+21 ;S CPTNOD8=""
+22 ;K ^UTILITY("DIQ1",$J) S DIC=81,DA=PXSCPT,DR=3,DIQ(0)="EIN" D EN^DIQ1
+23 ;I $G(^UTILITY("DIQ1",$J,81,DA,3,"I")) D
+24 ;.S PXSZPN=$G(^UTILITY("DIQ1",$J,81,DA,3,"E"))
+25 ;.S CPTNOD8=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE)
+26 ;.I CPTNOD8'>0 S CPTNOD8=""
+27 ;K ^UTILITY("DIQ1",$J),DIC,DA,DR,DIQ
+28 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,0,"AFTER")=$GET(CPTNOD0)
+29 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,0,"BEFORE")=""
+30 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,1,1,"BEFORE")=""
+31 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,12,"AFTER")=$GET(CPTNOD12)
+32 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,12,"BEFORE")=""
+33 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,802,"AFTER")=""
+34 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,802,"BEFORE")=""
+35 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,"IEN")=""
+36 SET ^TMP("PXK",$JOB,"SOR")=8
+37 SET ^TMP("PXK",$JOB,"VST",1,"IEN")=$GET(PXS("VISIT"))
CPTDUP ;Look for duplicates on the same visit
+1 NEW XPFG,XP,PXKSEQ,PXKMOD
+2 SET (XPFG,XP)=0
+3 FOR
if XPFG
QUIT
SET XP=$ORDER(^AUPNVCPT("AD",PXS("VISIT"),XP))
if XP=""
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNVCPT(XP,0),"^",1)=PXSCPT
Begin DoDot:2
+5 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,0,"BEFORE")=$GET(^AUPNVCPT(XP,0))
+6 SET PXKSEQ=0
+7 FOR
SET PXKSEQ=$ORDER(^AUPNVCPT(XP,1,PXKSEQ))
if 'PXKSEQ
QUIT
Begin DoDot:3
+8 SET PXKMOD=^AUPNVCPT(XP,1,PXKSEQ,0)
+9 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,1,PXKSEQ,"BEFORE")=PXKMOD
End DoDot:3
+10 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,12,"BEFORE")=$GET(^AUPNVCPT(XP,12))
+11 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,802,"BEFORE")=+$GET(^AUPNVCPT(XP,802))
+12 SET ^TMP("PXK",$JOB,"CPT",PXSINDX+1,"IEN")=XP
+13 SET XPFG=1
End DoDot:2
End DoDot:1
+14 QUIT
