PXAPIOE ;ALB/MJK,ESW - Supported References for ACRP ; 12/5/02 11:27am
;;1.0;PCE PATIENT CARE ENCOUNTER;**39,73,108**;Aug 12, 1996
;
;
CPT(PXVIEN,PXERR) ; -- at least one cpt for visit??
;
N PXOK
S PXOK=0
;
; -- do validation checks
IF '$$VALVST(PXVIEN,$G(PXERR)) G CPTQ
;
S PXOK=($O(^AUPNVCPT("AD",PXVIEN,0))>0)
CPTQ Q PXOK
;
;
GETCPT(PXVIEN,PXCPT,PXERR) ; -- get cpt's for visit
;
; -- do validation checks
IF '$$VALVST(PXVIEN,$G(PXERR)) G GETCPTQ
;
N I,CNT S (I,CNT)=0 F S I=$O(^AUPNVCPT("AD",PXVIEN,I)) Q:'I D
. IF $D(^AUPNVCPT(I,0)) S @PXCPT@(I)=^(0),CNT=CNT+1
S @PXCPT=CNT
GETCPTQ Q
;
CPTARR(PXVIEN,PXCPT,PXERR) ;+API to return all CPT data for a visit.
N IEN,CNT
S (IEN,CNT)=0
Q:'$$VALVST(PXVIEN,$G(PXERR))
F S IEN=$O(^AUPNVCPT("AD",PXVIEN,IEN)) Q:'IEN D
. Q:'$D(^AUPNVCPT(IEN))
. M @PXCPT@(IEN)=^AUPNVCPT(IEN)
. S CNT=CNT+1
S @PXCPT=CNT
Q
;
DX(PXVIEN,PXERR) ; -- at least one dx for visit??
;
N PXOK
S PXOK=0
;
; -- do validation checks
IF '$$VALVST(PXVIEN,$G(PXERR)) G DXQ
;
S PXOK=($O(^AUPNVPOV("AD",PXVIEN,0))>0)
DXQ Q PXOK
;
;
GETDX(PXVIEN,PXDX,PXERR) ; -- get dx's for visit
;
; -- do validation checks
IF '$$VALVST(PXVIEN,$G(PXERR)) G GETDXQ
;
N I,CNT S (I,CNT)=0 F S I=$O(^AUPNVPOV("AD",PXVIEN,I)) Q:'I D
. IF $D(^AUPNVPOV(I,0)) S @PXDX@(I)=^(0),CNT=CNT+1
S @PXDX=CNT
GETDXQ Q
;
;
PRV(PXVIEN,PXERR) ; -- at least one provider for visit?
;
N PXOK
S PXOK=0
;
; -- do validation checks
IF '$$VALVST(PXVIEN,$G(PXERR)) G PRVQ
S PXOK=($O(^AUPNVPRV("AD",PXVIEN,0))>0)
PRVQ Q PXOK
;
;
GETPRV(PXVIEN,PXPRV,PXERR) ; -- get provider's for visit;108
;
; -- do validation checks
IF '$$VALVST(PXVIEN,$G(PXERR)) G GETPRVQ
;
;PX*1*108;look for duplicates to exclude them
N I,CNT,PR,PRS,PS,PP,PRV
S (I,CNT)=0 F S I=$O(^AUPNVPRV("AD",PXVIEN,I)) Q:'I D
.IF $D(^AUPNVPRV(I,0)) D
..S @PXPRV@(I)=^(0),PR=+@PXPRV@(I),PS=$P(@PXPRV@(I),U,4)
..IF PS="P" D
...I 'CNT S PRV=PR,CNT=1 Q
...I PR=PRV K @PXPRV@(I)
..I PS="S" S PRS(PR,I)=""
S PR="" F S PR=$O(PRS(PR)) Q:PR="" S I="" D
.F PP=1:1 S I=$O(PRS(PR,I)) Q:I="" D
..I PR=$G(PRV) K @PXPRV@(I) Q
..I PP>1 K @PXPRV@(I)
..E S CNT=CNT+1
S @PXPRV=CNT
GETPRVQ Q
;
;
VALVST(PXVIEN,PXERR) ; -- validate visit ien input
;
; -- do checks
IF PXVIEN,$D(^AUPNVSIT(PXVIEN,0)) Q 1
;
; -- build error msg
N PXIN,PXOUT
S PXIN("ID")=PXVIEN
S PXOUT("ID")=PXVIEN
D BLD^DIALOG(1509000.001,.PXIN,.PXOUT,$G(PXERR),"F")
Q 0
;
;
POST ; -- post error action logic
;ZW DO
;ZW DIPI
;ZW DIPE
Q
;
;
PDX(VSTPOV,RANK) ; -- set primary dx for V POV entry
;
N VSTRT,VSTSEQ
N VSTIEN,X
;
; -- set up structures
D INIT(.VSTRT,.VSTSEQ)
;
; -- set up visit
S X=$G(^AUPNVPOV(VSTPOV,0))
S VSTIEN=+$P(X,U,3)
D VNODES(VSTIEN,VSTRT,VSTSEQ)
;
; -- set up dx
D DXNODES(VSTPOV,VSTRT,VSTSEQ)
S $P(@VSTRT@("POV",1,0,"AFTER"),U,12)=RANK
;
; -- file change and kill
D FINAL(VSTRT)
Q
;
;
PCLASS(VSTPRV) ; -- set provider class for V PRV entry
;
N VSTRT,VSTSEQ
N VSTIEN,X
;
; -- set up structures
D INIT(.VSTRT,.VSTSEQ)
;
; -- set up visit
S X=$G(^AUPNVPRV(VSTPRV,0))
S VSTIEN=+$P(X,U,3)
D VNODES(VSTIEN,VSTRT,VSTSEQ)
;
; -- set up provider ; pxkmain will automatically set class
D PRVNODES(VSTPRV,VSTRT,VSTSEQ)
;
; -- file change and kill
D FINAL(VSTRT)
Q
;
;
INIT(VSTRT,VSTSEQ) ; -- set up structures
S VSTRT=$NA(^TMP("PXK",$J))
S VSTSEQ=1
K @VSTRT
S @VSTRT@("SOR")=$O(^PX(839.7,"B","PIMS",0))
Q
;
;
FINAL(VSTRT) ; -- file data and clean up
N PXKNOEVT
S PXKNOEVT=1
D EN1^PXKMAIN
K @VSTRT
Q
;
;
VNODES(VSTIEN,VSTRT,VSTSEQ) ; -- get visit nodes
N NODE,X
S @VSTRT@("VST",VSTSEQ,"IEN")=VSTIEN
F NODE=0,21,150,800,811,812 D
. S X=$G(^AUPNVSIT(VSTIEN,NODE))
. S @VSTRT@("VST",VSTSEQ,NODE,"BEFORE")=X
. S @VSTRT@("VST",VSTSEQ,NODE,"AFTER")=X
Q
;
;
DXNODES(VSTPOV,VSTRT,VSTSEQ) ; -- get dx nodes
N NODE,X
S @VSTRT@("POV",VSTSEQ,"IEN")=VSTPOV
F NODE=0,12,812 D
. S X=$G(^AUPNVPOV(VSTPOV,NODE))
. S @VSTRT@("POV",VSTSEQ,NODE,"BEFORE")=X
. S @VSTRT@("POV",VSTSEQ,NODE,"AFTER")=X
Q
;
;
PRVNODES(VSTPRV,VSTRT,VSTSEQ) ; -- get provider nodes
N NODE,X
S @VSTRT@("PRV",VSTSEQ,"IEN")=VSTPRV
F NODE=0,12,812 D
. S X=$G(^AUPNVPRV(VSTPRV,NODE))
. S @VSTRT@("PRV",VSTSEQ,NODE,"BEFORE")=X
. S @VSTRT@("PRV",VSTSEQ,NODE,"AFTER")=X
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXAPIOE 4493 printed Apr 09, 2024@21:31:45 Page 2
PXAPIOE ;ALB/MJK,ESW - Supported References for ACRP ; 12/5/02 11:27am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**39,73,108**;Aug 12, 1996
+2 ;
+3 ;
CPT(PXVIEN,PXERR) ; -- at least one cpt for visit??
+1 ;
+2 NEW PXOK
+3 SET PXOK=0
+4 ;
+5 ; -- do validation checks
+6 IF '$$VALVST(PXVIEN,$GET(PXERR))
GOTO CPTQ
+7 ;
+8 SET PXOK=($ORDER(^AUPNVCPT("AD",PXVIEN,0))>0)
CPTQ QUIT PXOK
+1 ;
+2 ;
GETCPT(PXVIEN,PXCPT,PXERR) ; -- get cpt's for visit
+1 ;
+2 ; -- do validation checks
+3 IF '$$VALVST(PXVIEN,$GET(PXERR))
GOTO GETCPTQ
+4 ;
+5 NEW I,CNT
SET (I,CNT)=0
FOR
SET I=$ORDER(^AUPNVCPT("AD",PXVIEN,I))
if 'I
QUIT
Begin DoDot:1
+6 IF $DATA(^AUPNVCPT(I,0))
SET @PXCPT@(I)=^(0)
SET CNT=CNT+1
End DoDot:1
+7 SET @PXCPT=CNT
GETCPTQ QUIT
+1 ;
CPTARR(PXVIEN,PXCPT,PXERR) ;+API to return all CPT data for a visit.
+1 NEW IEN,CNT
+2 SET (IEN,CNT)=0
+3 if '$$VALVST(PXVIEN,$GET(PXERR))
QUIT
+4 FOR
SET IEN=$ORDER(^AUPNVCPT("AD",PXVIEN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 if '$DATA(^AUPNVCPT(IEN))
QUIT
+6 MERGE @PXCPT@(IEN)=^AUPNVCPT(IEN)
+7 SET CNT=CNT+1
End DoDot:1
+8 SET @PXCPT=CNT
+9 QUIT
+10 ;
DX(PXVIEN,PXERR) ; -- at least one dx for visit??
+1 ;
+2 NEW PXOK
+3 SET PXOK=0
+4 ;
+5 ; -- do validation checks
+6 IF '$$VALVST(PXVIEN,$GET(PXERR))
GOTO DXQ
+7 ;
+8 SET PXOK=($ORDER(^AUPNVPOV("AD",PXVIEN,0))>0)
DXQ QUIT PXOK
+1 ;
+2 ;
GETDX(PXVIEN,PXDX,PXERR) ; -- get dx's for visit
+1 ;
+2 ; -- do validation checks
+3 IF '$$VALVST(PXVIEN,$GET(PXERR))
GOTO GETDXQ
+4 ;
+5 NEW I,CNT
SET (I,CNT)=0
FOR
SET I=$ORDER(^AUPNVPOV("AD",PXVIEN,I))
if 'I
QUIT
Begin DoDot:1
+6 IF $DATA(^AUPNVPOV(I,0))
SET @PXDX@(I)=^(0)
SET CNT=CNT+1
End DoDot:1
+7 SET @PXDX=CNT
GETDXQ QUIT
+1 ;
+2 ;
PRV(PXVIEN,PXERR) ; -- at least one provider for visit?
+1 ;
+2 NEW PXOK
+3 SET PXOK=0
+4 ;
+5 ; -- do validation checks
+6 IF '$$VALVST(PXVIEN,$GET(PXERR))
GOTO PRVQ
+7 SET PXOK=($ORDER(^AUPNVPRV("AD",PXVIEN,0))>0)
PRVQ QUIT PXOK
+1 ;
+2 ;
GETPRV(PXVIEN,PXPRV,PXERR) ; -- get provider's for visit;108
+1 ;
+2 ; -- do validation checks
+3 IF '$$VALVST(PXVIEN,$GET(PXERR))
GOTO GETPRVQ
+4 ;
+5 ;PX*1*108;look for duplicates to exclude them
+6 NEW I,CNT,PR,PRS,PS,PP,PRV
+7 SET (I,CNT)=0
FOR
SET I=$ORDER(^AUPNVPRV("AD",PXVIEN,I))
if 'I
QUIT
Begin DoDot:1
+8 IF $DATA(^AUPNVPRV(I,0))
Begin DoDot:2
+9 SET @PXPRV@(I)=^(0)
SET PR=+@PXPRV@(I)
SET PS=$PIECE(@PXPRV@(I),U,4)
+10 IF PS="P"
Begin DoDot:3
+11 IF 'CNT
SET PRV=PR
SET CNT=1
QUIT
+12 IF PR=PRV
KILL @PXPRV@(I)
End DoDot:3
+13 IF PS="S"
SET PRS(PR,I)=""
End DoDot:2
End DoDot:1
+14 SET PR=""
FOR
SET PR=$ORDER(PRS(PR))
if PR=""
QUIT
SET I=""
Begin DoDot:1
+15 FOR PP=1:1
SET I=$ORDER(PRS(PR,I))
if I=""
QUIT
Begin DoDot:2
+16 IF PR=$GET(PRV)
KILL @PXPRV@(I)
QUIT
+17 IF PP>1
KILL @PXPRV@(I)
+18 IF '$TEST
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+19 SET @PXPRV=CNT
GETPRVQ QUIT
+1 ;
+2 ;
VALVST(PXVIEN,PXERR) ; -- validate visit ien input
+1 ;
+2 ; -- do checks
+3 IF PXVIEN
IF $DATA(^AUPNVSIT(PXVIEN,0))
QUIT 1
+4 ;
+5 ; -- build error msg
+6 NEW PXIN,PXOUT
+7 SET PXIN("ID")=PXVIEN
+8 SET PXOUT("ID")=PXVIEN
+9 DO BLD^DIALOG(1509000.001,.PXIN,.PXOUT,$GET(PXERR),"F")
+10 QUIT 0
+11 ;
+12 ;
POST ; -- post error action logic
+1 ;ZW DO
+2 ;ZW DIPI
+3 ;ZW DIPE
+4 QUIT
+5 ;
+6 ;
PDX(VSTPOV,RANK) ; -- set primary dx for V POV entry
+1 ;
+2 NEW VSTRT,VSTSEQ
+3 NEW VSTIEN,X
+4 ;
+5 ; -- set up structures
+6 DO INIT(.VSTRT,.VSTSEQ)
+7 ;
+8 ; -- set up visit
+9 SET X=$GET(^AUPNVPOV(VSTPOV,0))
+10 SET VSTIEN=+$PIECE(X,U,3)
+11 DO VNODES(VSTIEN,VSTRT,VSTSEQ)
+12 ;
+13 ; -- set up dx
+14 DO DXNODES(VSTPOV,VSTRT,VSTSEQ)
+15 SET $PIECE(@VSTRT@("POV",1,0,"AFTER"),U,12)=RANK
+16 ;
+17 ; -- file change and kill
+18 DO FINAL(VSTRT)
+19 QUIT
+20 ;
+21 ;
PCLASS(VSTPRV) ; -- set provider class for V PRV entry
+1 ;
+2 NEW VSTRT,VSTSEQ
+3 NEW VSTIEN,X
+4 ;
+5 ; -- set up structures
+6 DO INIT(.VSTRT,.VSTSEQ)
+7 ;
+8 ; -- set up visit
+9 SET X=$GET(^AUPNVPRV(VSTPRV,0))
+10 SET VSTIEN=+$PIECE(X,U,3)
+11 DO VNODES(VSTIEN,VSTRT,VSTSEQ)
+12 ;
+13 ; -- set up provider ; pxkmain will automatically set class
+14 DO PRVNODES(VSTPRV,VSTRT,VSTSEQ)
+15 ;
+16 ; -- file change and kill
+17 DO FINAL(VSTRT)
+18 QUIT
+19 ;
+20 ;
INIT(VSTRT,VSTSEQ) ; -- set up structures
+1 SET VSTRT=$NAME(^TMP("PXK",$JOB))
+2 SET VSTSEQ=1
+3 KILL @VSTRT
+4 SET @VSTRT@("SOR")=$ORDER(^PX(839.7,"B","PIMS",0))
+5 QUIT
+6 ;
+7 ;
FINAL(VSTRT) ; -- file data and clean up
+1 NEW PXKNOEVT
+2 SET PXKNOEVT=1
+3 DO EN1^PXKMAIN
+4 KILL @VSTRT
+5 QUIT
+6 ;
+7 ;
VNODES(VSTIEN,VSTRT,VSTSEQ) ; -- get visit nodes
+1 NEW NODE,X
+2 SET @VSTRT@("VST",VSTSEQ,"IEN")=VSTIEN
+3 FOR NODE=0,21,150,800,811,812
Begin DoDot:1
+4 SET X=$GET(^AUPNVSIT(VSTIEN,NODE))
+5 SET @VSTRT@("VST",VSTSEQ,NODE,"BEFORE")=X
+6 SET @VSTRT@("VST",VSTSEQ,NODE,"AFTER")=X
End DoDot:1
+7 QUIT
+8 ;
+9 ;
DXNODES(VSTPOV,VSTRT,VSTSEQ) ; -- get dx nodes
+1 NEW NODE,X
+2 SET @VSTRT@("POV",VSTSEQ,"IEN")=VSTPOV
+3 FOR NODE=0,12,812
Begin DoDot:1
+4 SET X=$GET(^AUPNVPOV(VSTPOV,NODE))
+5 SET @VSTRT@("POV",VSTSEQ,NODE,"BEFORE")=X
+6 SET @VSTRT@("POV",VSTSEQ,NODE,"AFTER")=X
End DoDot:1
+7 QUIT
+8 ;
+9 ;
PRVNODES(VSTPRV,VSTRT,VSTSEQ) ; -- get provider nodes
+1 NEW NODE,X
+2 SET @VSTRT@("PRV",VSTSEQ,"IEN")=VSTPRV
+3 FOR NODE=0,12,812
Begin DoDot:1
+4 SET X=$GET(^AUPNVPRV(VSTPRV,NODE))
+5 SET @VSTRT@("PRV",VSTSEQ,NODE,"BEFORE")=X
+6 SET @VSTRT@("PRV",VSTSEQ,NODE,"AFTER")=X
End DoDot:1
+7 QUIT
+8 ;
