SDOEDX ;ALB/MJK - ACRP DX APIs For An Encounter ;8/12/96
;;5.3;PIMS;**131,1015,1016**;JUN 30, 2012;Build 20
;
DX(SDOE,SDERR) ; -- SDOE ASSIGNED A DIAGNOSIS
; API ID: 64
;
;
N SDOK
S SDOK=0
;
; -- do validation checks
IF '$$VALOE^SDOEOE(.SDOE,$G(SDERR)) G DXQ
IF $$OLD^SDOEUT(SDOE) S SDOK=$$OLDDX(SDOE) G DXQ
;
S SDOK=$$DX^PXAPIOE($$VIEN^SDOEUT(.SDOE),$G(SDERR))
DXQ Q SDOK
;
;
GETDX(SDOE,SDDX,SDERR) ; -- SDOE GET DIAGNOSES
; API ID: 56
;
;
GETDXG ; -- goto entry point
;
; -- do validation checks
IF '$$VALOE^SDOEOE(.SDOE,$G(SDERR)) G GETDXQ
IF $$OLD^SDOEUT(SDOE) D OLDDXS(SDOE,.SDDX) G GETDXQ
;
D GETDX^PXAPIOE($$VIEN^SDOEUT(.SDOE),.SDDX,$G(SDERR))
GETDXQ Q
;
;
FINDDX(SDOE,SDDXID,SDERR) ; -- SDOE FIND DIAGNOSIS
; API ID: 70
;
;
N SDDXS,SDOK,I
S SDDXS="SDDXS"
;
; -- do validation checks
IF '$$VALDX(.SDDXID,$G(SDERR)) S SDOK=0 G FINDDXQ
;
D GETDX(.SDOE,.SDDXS,$G(SDERR))
S (I,SDOK)=0
F S I=$O(SDDXS(I)) Q:'I S SDOK=(+SDDXS(I)=SDDXID) Q:SDOK
FINDDXQ Q SDOK
;
;
GETPDX(SDOE,SDERR) ; -- SDOE GET PRIMARY DIAGNOSIS
; API ID: 73
;
;
N SDDXS,I,SDPDX,CNT
S SDDXS="SDDXS"
D GETDX(.SDOE,.SDDXS,$G(SDERR))
;
; -- how many are primaries / kill secondaries from array
S (CNT,I)=0
F S I=$O(SDDXS(I)) Q:'I S X=$P(SDDXS(I),"^",12) S:X="P" CNT=CNT+1 K:X'="P" SDDXS(I)
S SDPDX=+$G(SDDXS(+$O(SDDXS(0))))
;
; -- check for too many primaries & build error msg
IF CNT>1 D
. N DFN,DFN0,SDIN,SDOUT,Y,I,VA
. ;
. S SDPDX=0
. S DFN=+$P($G(^SCE(+SDOE,0)),"^",2)
. S DFN0=$G(^DPT(DFN,0))
. D PID^VADPT6
. ;
. S SDIN("ID")=SDOE,SDOUT("ID")=SDOE
. S SDIN("DFN")=DFN,SDOUT("DFN")=DFN
. S SDIN("PATNAME")=$P(DFN0,"^"),SDOUT("PATNAME")=$P(DFN0,"^")
. S SDIN("PID")=VA("PID"),SDOUT("PID")=VA("PID")
. ;
. S I=0,Y=""
. F S I=$O(SDDX(I)) Q:'I S Y=$P($G(^ICD9(+SDDXS,0)),"^")_" "
. S SDIN("CODES")=Y,SDOUT("CODES")=Y
. ;
. D BLD^SDQVAL(4096800.025,.SDIN,.SDOUT,$G(SDERR))
;
GETPDXQ Q SDPDX
;
;
VALDX(SDDXID,SDERR) ; -- validate dx input
;
; -- do checks
;IF SDDXID,$D(^ICD9(SDDXID,0)) Q 1
I SDDXID,+$$ICDDX^ICDCODE(SDDXID)>0 Q 1
;
; -- build error msg
N SDIN,SDOUT
S SDIN("ID")=SDDXID
S SDOUT("ID")=SDDXID
D BLD^SDQVAL(4096800.004,.SDIN,.SDOUT,$G(SDERR))
Q 0
;
;
OLDDX(SDOE) ; -- at least one dx for OLD encounter?
Q ($O(^SDD(409.43,"OE",+SDOE,0))>0)
;
OLDDXS(SDOE,SDARY) ; -- get DX's for OLD encounter
N SDIEN,SDCNT,Y,X
S (SDIEN,SDCNT)=0
F S SDIEN=$O(^SDD(409.43,"OE",SDOE,SDIEN)) Q:'SDIEN D
. S SDCNT=SDCNT+1,X=$G(^SDD(409.43,SDIEN,0))
. S $P(Y,U,1)=+X ; -- dx ien
. S $P(Y,U,12)=$S($P(X,"^",3)=1:"P",1:"S") ; -- primary dx?
. S @SDARY@(SDIEN)=Y
S @SDARY=SDCNT
Q
;
SDOEDX ;ALB/MJK - ACRP DX APIs For An Encounter ;8/12/96
+1 ;;5.3;PIMS;**131,1015,1016**;JUN 30, 2012;Build 20
+2 ;
DX(SDOE,SDERR) ; -- SDOE ASSIGNED A DIAGNOSIS
+1 ; API ID: 64
+2 ;
+3 ;
+4 NEW SDOK
+5 SET SDOK=0
+6 ;
+7 ; -- do validation checks
+8 IF '$$VALOE^SDOEOE(.SDOE,$GET(SDERR))
GOTO DXQ
+9 IF $$OLD^SDOEUT(SDOE)
SET SDOK=$$OLDDX(SDOE)
GOTO DXQ
+10 ;
+11 SET SDOK=$$DX^PXAPIOE($$VIEN^SDOEUT(.SDOE),$GET(SDERR))
DXQ QUIT SDOK
+1 ;
+2 ;
GETDX(SDOE,SDDX,SDERR) ; -- SDOE GET DIAGNOSES
+1 ; API ID: 56
+2 ;
+3 ;
GETDXG ; -- goto entry point
+1 ;
+2 ; -- do validation checks
+3 IF '$$VALOE^SDOEOE(.SDOE,$GET(SDERR))
GOTO GETDXQ
+4 IF $$OLD^SDOEUT(SDOE)
DO OLDDXS(SDOE,.SDDX)
GOTO GETDXQ
+5 ;
+6 DO GETDX^PXAPIOE($$VIEN^SDOEUT(.SDOE),.SDDX,$GET(SDERR))
GETDXQ QUIT
+1 ;
+2 ;
FINDDX(SDOE,SDDXID,SDERR) ; -- SDOE FIND DIAGNOSIS
+1 ; API ID: 70
+2 ;
+3 ;
+4 NEW SDDXS,SDOK,I
+5 SET SDDXS="SDDXS"
+6 ;
+7 ; -- do validation checks
+8 IF '$$VALDX(.SDDXID,$GET(SDERR))
SET SDOK=0
GOTO FINDDXQ
+9 ;
+10 DO GETDX(.SDOE,.SDDXS,$GET(SDERR))
+11 SET (I,SDOK)=0
+12 FOR
SET I=$ORDER(SDDXS(I))
IF 'I
QUIT
SET SDOK=(+SDDXS(I)=SDDXID)
IF SDOK
QUIT
FINDDXQ QUIT SDOK
+1 ;
+2 ;
GETPDX(SDOE,SDERR) ; -- SDOE GET PRIMARY DIAGNOSIS
+1 ; API ID: 73
+2 ;
+3 ;
+4 NEW SDDXS,I,SDPDX,CNT
+5 SET SDDXS="SDDXS"
+6 DO GETDX(.SDOE,.SDDXS,$GET(SDERR))
+7 ;
+8 ; -- how many are primaries / kill secondaries from array
+9 SET (CNT,I)=0
+10 FOR
SET I=$ORDER(SDDXS(I))
IF 'I
QUIT
SET X=$PIECE(SDDXS(I),"^",12)
IF X="P"
SET CNT=CNT+1
IF X'="P"
KILL SDDXS(I)
+11 SET SDPDX=+$GET(SDDXS(+$ORDER(SDDXS(0))))
+12 ;
+13 ; -- check for too many primaries & build error msg
+14 IF CNT>1
Begin DoDot:1
+15 NEW DFN,DFN0,SDIN,SDOUT,Y,I,VA
+16 ;
+17 SET SDPDX=0
+18 SET DFN=+$PIECE($GET(^SCE(+SDOE,0)),"^",2)
+19 SET DFN0=$GET(^DPT(DFN,0))
+20 DO PID^VADPT6
+21 ;
+22 SET SDIN("ID")=SDOE
SET SDOUT("ID")=SDOE
+23 SET SDIN("DFN")=DFN
SET SDOUT("DFN")=DFN
+24 SET SDIN("PATNAME")=$PIECE(DFN0,"^")
SET SDOUT("PATNAME")=$PIECE(DFN0,"^")
+25 SET SDIN("PID")=VA("PID")
SET SDOUT("PID")=VA("PID")
+26 ;
+27 SET I=0
SET Y=""
+28 FOR
SET I=$ORDER(SDDX(I))
IF 'I
QUIT
SET Y=$PIECE($GET(^ICD9(+SDDXS,0)),"^")_" "
+29 SET SDIN("CODES")=Y
SET SDOUT("CODES")=Y
+30 ;
+31 DO BLD^SDQVAL(4096800.025,.SDIN,.SDOUT,$GET(SDERR))
End DoDot:1
+32 ;
GETPDXQ QUIT SDPDX
+1 ;
+2 ;
VALDX(SDDXID,SDERR) ; -- validate dx input
+1 ;
+2 ; -- do checks
+3 ;IF SDDXID,$D(^ICD9(SDDXID,0)) Q 1
+4 IF SDDXID
IF +$$ICDDX^ICDCODE(SDDXID)>0
QUIT 1
+5 ;
+6 ; -- build error msg
+7 NEW SDIN,SDOUT
+8 SET SDIN("ID")=SDDXID
+9 SET SDOUT("ID")=SDDXID
+10 DO BLD^SDQVAL(4096800.004,.SDIN,.SDOUT,$GET(SDERR))
+11 QUIT 0
+12 ;
+13 ;
OLDDX(SDOE) ; -- at least one dx for OLD encounter?
+1 QUIT ($ORDER(^SDD(409.43,"OE",+SDOE,0))>0)
+2 ;
OLDDXS(SDOE,SDARY) ; -- get DX's for OLD encounter
+1 NEW SDIEN,SDCNT,Y,X
+2 SET (SDIEN,SDCNT)=0
+3 FOR
SET SDIEN=$ORDER(^SDD(409.43,"OE",SDOE,SDIEN))
IF 'SDIEN
QUIT
Begin DoDot:1
+4 SET SDCNT=SDCNT+1
SET X=$GET(^SDD(409.43,SDIEN,0))
+5 ; -- dx ien
SET $PIECE(Y,U,1)=+X
+6 ; -- primary dx?
SET $PIECE(Y,U,12)=$SELECT($PIECE(X,"^",3)=1:"P",1:"S")
+7 SET @SDARY@(SDIEN)=Y
End DoDot:1
+8 SET @SDARY=SDCNT
+9 QUIT
+10 ;
