PXAISC ;SLC/PKR - Set V STANDARD CODES and Problem List. ;04/03/2018
;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
;
Q
SC ;--Create V STANDRD CODES entry
;
SET ;--SET AND NEW VARIABLES
N AFTER0,AFTER12,AFTER220,AFTER801,AFTER802,AFTER811,AFTER812
N BEFOR0,BEFOR12,BEFOR220,BEFOR801,BEFOR802,BEFOR811,BEFOR812
N IENB,NODE,PXAA,STOP,SUB
;
K PXAERR
S PXAERR(8)=PXAK
S PXAERR(7)="STD CODES"
;
S SUB="" F S SUB=$O(@PXADATA@("STD CODES",PXAK,SUB)) Q:SUB="" D
.S PXAA(SUB)=@PXADATA@("STD CODES",PXAK,SUB)
;
;--VALIDATE ENOUGH DATA
D VAL^PXAISCV Q:$G(STOP)
;
SETVARA ;--SET VISIT VARIABLES
S $P(AFTER0,"^",1)=$G(PXAA("CODE"))
I $G(PXAA("DELETE")) S $P(AFTER0,"^",1)="@"
S $P(AFTER0,"^",2)=$G(PATIENT),PXAA("PATIENT")=$G(PATIENT)
S $P(AFTER0,"^",3)=$G(PXAVISIT)
S $P(AFTER0,"^",5)=$G(PXAA("CODING SYSTEM"))
S $P(AFTER12,"^",1)=$G(PXAA("EVENT D/T"))
S $P(AFTER12,"^",2)=$G(PXAA("ORD PROVIDER"))
S $P(AFTER12,"^",4)=$G(PXAA("ENC PROVIDER"))
;
;Magnitude and UCUM code
S $P(AFTER220,U,1)=$G(PXAA("MAGNITUDE"))
S $P(AFTER220,U,2)=$G(PXAA("UCUM CODE"))
;
I $G(PXAA("ENC PROVIDER"))]"",'$G(PXAA("DELETE")) D
.S ^TMP("PXAIADDPRV",$J,$G(PXAA("ENC PROVIDER")))=""
;
S $P(AFTER811,"^",1)=$G(PXAA("COMMENT"))
;
S $P(AFTER812,"^",2)=$S($G(PXAA("PKG"))'="":PXAA("PKG"),1:$G(PXAPKG))
S $P(AFTER812,"^",3)=$S($G(PXAA("SOURCE"))'="":PXAA("SOURCE"),1:$G(PXASOURC))
;
;How do we make this work?
;D PL^PXAIPL
;
;
SETPXKA ;--SET PXK ARRAY AFTER
S ^TMP("PXK",$J,"SC",PXAK,0,"AFTER")=$G(AFTER0)
S ^TMP("PXK",$J,"SC",PXAK,12,"AFTER")=$G(AFTER12)
S ^TMP("PXK",$J,"SC",PXAK,220,"AFTER")=$G(AFTER220)
S ^TMP("PXK",$J,"SC",PXAK,802,"AFTER")=$G(AFTER802)
S ^TMP("PXK",$J,"SC",PXAK,811,"AFTER")=$G(AFTER811)
S ^TMP("PXK",$J,"SC",PXAK,812,"AFTER")=$G(AFTER812)
;
SETVARB ;--SET VARIABLES BEFORE
;
;--GET LIST OF POSSIBLE BEFORE ENTRIES
N SCIENLST
D SC^PXBGSC(PXAVISIT,.SCIENLST)
;
BEFOR ;
S IEN=""
I $D(SCIENLST) S IEN=$O(SCIENLST(PXAA("CODE"),PXAA("CODING SYSTEM"),""))
I IEN="" S (BEFOR0,BEFOR12,BEFOR220,BEFOR800,BEFOR802,BEFOR811,BEFOR812)=""
I +IEN>0 D
. S BEFOR0=^AUPNVSC(IEN,0)
. S BEFOR12=$G(^AUPNVSC(IEN,12))
. S BEFOR220=$G(^AUPNVSC(IEN,220))
. S BEFOR800=$G(^AUPNVSC(IEN,800))
. S BEFOR811=$G(^AUPNVSC(IEN,811))
. S BEFOR812=$G(^AUPNVSC(IEN,812))
.;
SETPXKB ;--SET PXK ARRAY BEFORE
S ^TMP("PXK",$J,"SC",PXAK,0,"BEFORE")=$G(BEFOR0)
S ^TMP("PXK",$J,"SC",PXAK,12,"BEFORE")=$G(BEFOR12)
S ^TMP("PXK",$J,"SC",PXAK,220,"BEFORE")=$G(BEFOR220)
S ^TMP("PXK",$J,"SC",PXAK,800,"BEFORE")=$G(BEFOR800)
S ^TMP("PXK",$J,"SC",PXAK,802,"BEFORE")=$G(BEFOR802)
S ^TMP("PXK",$J,"SC",PXAK,811,"BEFORE")=$G(BEFOR811)
S ^TMP("PXK",$J,"SC",PXAK,812,"BEFORE")=$G(BEFOR812)
S ^TMP("PXK",$J,"SC",PXAK,"IEN")=IEN
;
;Package and Data Source cannot be edited.
S BEFOR812=^TMP("PXK",$J,"SC",PXAK,812,"BEFORE")
I BEFOR812'="" D
. I AFTER812=BEFOR812 Q
. I $P(BEFOR812,U,2)'="" S $P(AFTER812,U,2)=$P(BEFOR812,U,2)
. I $P(BEFOR812,U,3)'="" S $P(AFTER812,U,3)=$P(BEFOR812,U,3)
. S ^TMP("PXK",$J,"SC",PXAK,812,"AFTER")=AFTER812
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXAISC 3163 printed Apr 09, 2024@21:29:23 Page 2
PXAISC ;SLC/PKR - Set V STANDARD CODES and Problem List. ;04/03/2018
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
+2 ;
+3 QUIT
SC ;--Create V STANDRD CODES entry
+1 ;
SET ;--SET AND NEW VARIABLES
+1 NEW AFTER0,AFTER12,AFTER220,AFTER801,AFTER802,AFTER811,AFTER812
+2 NEW BEFOR0,BEFOR12,BEFOR220,BEFOR801,BEFOR802,BEFOR811,BEFOR812
+3 NEW IENB,NODE,PXAA,STOP,SUB
+4 ;
+5 KILL PXAERR
+6 SET PXAERR(8)=PXAK
+7 SET PXAERR(7)="STD CODES"
+8 ;
+9 SET SUB=""
FOR
SET SUB=$ORDER(@PXADATA@("STD CODES",PXAK,SUB))
if SUB=""
QUIT
Begin DoDot:1
+10 SET PXAA(SUB)=@PXADATA@("STD CODES",PXAK,SUB)
End DoDot:1
+11 ;
+12 ;--VALIDATE ENOUGH DATA
+13 DO VAL^PXAISCV
if $GET(STOP)
QUIT
+14 ;
SETVARA ;--SET VISIT VARIABLES
+1 SET $PIECE(AFTER0,"^",1)=$GET(PXAA("CODE"))
+2 IF $GET(PXAA("DELETE"))
SET $PIECE(AFTER0,"^",1)="@"
+3 SET $PIECE(AFTER0,"^",2)=$GET(PATIENT)
SET PXAA("PATIENT")=$GET(PATIENT)
+4 SET $PIECE(AFTER0,"^",3)=$GET(PXAVISIT)
+5 SET $PIECE(AFTER0,"^",5)=$GET(PXAA("CODING SYSTEM"))
+6 SET $PIECE(AFTER12,"^",1)=$GET(PXAA("EVENT D/T"))
+7 SET $PIECE(AFTER12,"^",2)=$GET(PXAA("ORD PROVIDER"))
+8 SET $PIECE(AFTER12,"^",4)=$GET(PXAA("ENC PROVIDER"))
+9 ;
+10 ;Magnitude and UCUM code
+11 SET $PIECE(AFTER220,U,1)=$GET(PXAA("MAGNITUDE"))
+12 SET $PIECE(AFTER220,U,2)=$GET(PXAA("UCUM CODE"))
+13 ;
+14 IF $GET(PXAA("ENC PROVIDER"))]""
IF '$GET(PXAA("DELETE"))
Begin DoDot:1
+15 SET ^TMP("PXAIADDPRV",$JOB,$GET(PXAA("ENC PROVIDER")))=""
End DoDot:1
+16 ;
+17 SET $PIECE(AFTER811,"^",1)=$GET(PXAA("COMMENT"))
+18 ;
+19 SET $PIECE(AFTER812,"^",2)=$SELECT($GET(PXAA("PKG"))'="":PXAA("PKG"),1:$GET(PXAPKG))
+20 SET $PIECE(AFTER812,"^",3)=$SELECT($GET(PXAA("SOURCE"))'="":PXAA("SOURCE"),1:$GET(PXASOURC))
+21 ;
+22 ;How do we make this work?
+23 ;D PL^PXAIPL
+24 ;
+25 ;
SETPXKA ;--SET PXK ARRAY AFTER
+1 SET ^TMP("PXK",$JOB,"SC",PXAK,0,"AFTER")=$GET(AFTER0)
+2 SET ^TMP("PXK",$JOB,"SC",PXAK,12,"AFTER")=$GET(AFTER12)
+3 SET ^TMP("PXK",$JOB,"SC",PXAK,220,"AFTER")=$GET(AFTER220)
+4 SET ^TMP("PXK",$JOB,"SC",PXAK,802,"AFTER")=$GET(AFTER802)
+5 SET ^TMP("PXK",$JOB,"SC",PXAK,811,"AFTER")=$GET(AFTER811)
+6 SET ^TMP("PXK",$JOB,"SC",PXAK,812,"AFTER")=$GET(AFTER812)
+7 ;
SETVARB ;--SET VARIABLES BEFORE
+1 ;
+2 ;--GET LIST OF POSSIBLE BEFORE ENTRIES
+3 NEW SCIENLST
+4 DO SC^PXBGSC(PXAVISIT,.SCIENLST)
+5 ;
BEFOR ;
+1 SET IEN=""
+2 IF $DATA(SCIENLST)
SET IEN=$ORDER(SCIENLST(PXAA("CODE"),PXAA("CODING SYSTEM"),""))
+3 IF IEN=""
SET (BEFOR0,BEFOR12,BEFOR220,BEFOR800,BEFOR802,BEFOR811,BEFOR812)=""
+4 IF +IEN>0
Begin DoDot:1
+5 SET BEFOR0=^AUPNVSC(IEN,0)
+6 SET BEFOR12=$GET(^AUPNVSC(IEN,12))
+7 SET BEFOR220=$GET(^AUPNVSC(IEN,220))
+8 SET BEFOR800=$GET(^AUPNVSC(IEN,800))
+9 SET BEFOR811=$GET(^AUPNVSC(IEN,811))
+10 SET BEFOR812=$GET(^AUPNVSC(IEN,812))
+11 ;
End DoDot:1
SETPXKB ;--SET PXK ARRAY BEFORE
+1 SET ^TMP("PXK",$JOB,"SC",PXAK,0,"BEFORE")=$GET(BEFOR0)
+2 SET ^TMP("PXK",$JOB,"SC",PXAK,12,"BEFORE")=$GET(BEFOR12)
+3 SET ^TMP("PXK",$JOB,"SC",PXAK,220,"BEFORE")=$GET(BEFOR220)
+4 SET ^TMP("PXK",$JOB,"SC",PXAK,800,"BEFORE")=$GET(BEFOR800)
+5 SET ^TMP("PXK",$JOB,"SC",PXAK,802,"BEFORE")=$GET(BEFOR802)
+6 SET ^TMP("PXK",$JOB,"SC",PXAK,811,"BEFORE")=$GET(BEFOR811)
+7 SET ^TMP("PXK",$JOB,"SC",PXAK,812,"BEFORE")=$GET(BEFOR812)
+8 SET ^TMP("PXK",$JOB,"SC",PXAK,"IEN")=IEN
+9 ;
+10 ;Package and Data Source cannot be edited.
+11 SET BEFOR812=^TMP("PXK",$JOB,"SC",PXAK,812,"BEFORE")
+12 IF BEFOR812'=""
Begin DoDot:1
+13 IF AFTER812=BEFOR812
QUIT
+14 IF $PIECE(BEFOR812,U,2)'=""
SET $PIECE(AFTER812,U,2)=$PIECE(BEFOR812,U,2)
+15 IF $PIECE(BEFOR812,U,3)'=""
SET $PIECE(AFTER812,U,3)=$PIECE(BEFOR812,U,3)
+16 SET ^TMP("PXK",$JOB,"SC",PXAK,812,"AFTER")=AFTER812
End DoDot:1
+17 ;
+18 QUIT
