- SDOEDX ;ALB/MJK - ACRP DX APIs For An Encounter ;8/12/96
- ;;5.3;Scheduling;**131,556,586**;Aug 13, 1993;Build 28
- ;
- ; Reference to $$ICDDX^ICDEX supported by ICR #5747
- ;
- 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,SDOEDT
- S SDDXS="SDDXS"
- ;
- ;get encounter date to pass to $$VALDX - SD*5.3*586
- S SDOEDT=$P($$GET1^DIQ(409.68,SDOE_",",.01,"I"),".",1)
- ; -- do validation checks
- IF '$$VALDX(.SDDXID,SDOEDT,$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,SDOEDT,SDERR) ; -- validate dx input
- ;
- ; -- do checks
- ;Patch SD*5.3*586
- I SDDXID,+$$ICDDX^ICDEX(SDDXID,SDOEDT,+$$SYS^ICDEX("DIAG",SDOEDT,"I"),"I") 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDOEDX 3005 printed Feb 19, 2025@00:25:35 Page 2
- SDOEDX ;ALB/MJK - ACRP DX APIs For An Encounter ;8/12/96
- +1 ;;5.3;Scheduling;**131,556,586**;Aug 13, 1993;Build 28
- +2 ;
- +3 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
- +4 ;
- 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,SDOEDT
- +5 SET SDDXS="SDDXS"
- +6 ;
- +7 ;get encounter date to pass to $$VALDX - SD*5.3*586
- +8 SET SDOEDT=$PIECE($$GET1^DIQ(409.68,SDOE_",",.01,"I"),".",1)
- +9 ; -- do validation checks
- +10 IF '$$VALDX(.SDDXID,SDOEDT,$GET(SDERR))
- SET SDOK=0
- GOTO FINDDXQ
- +11 ;
- +12 DO GETDX(.SDOE,.SDDXS,$GET(SDERR))
- +13 SET (I,SDOK)=0
- +14 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,SDOEDT,SDERR) ; -- validate dx input
- +1 ;
- +2 ; -- do checks
- +3 ;Patch SD*5.3*586
- +4 IF SDDXID
- IF +$$ICDDX^ICDEX(SDDXID,SDOEDT,+$$SYS^ICDEX("DIAG",SDOEDT,"I"),"I")
- 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 ;