Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDOEDX

SDOEDX.m

Go to the documentation of this file.
  1. SDOEDX ;ALB/MJK - ACRP DX APIs For An Encounter ;8/12/96
  1. ;;5.3;Scheduling;**131,556,586**;Aug 13, 1993;Build 28
  1. ;
  1. ; Reference to $$ICDDX^ICDEX supported by ICR #5747
  1. ;
  1. DX(SDOE,SDERR) ; -- SDOE ASSIGNED A DIAGNOSIS
  1. ; API ID: 64
  1. ;
  1. ;
  1. N SDOK
  1. S SDOK=0
  1. ;
  1. ; -- do validation checks
  1. IF '$$VALOE^SDOEOE(.SDOE,$G(SDERR)) G DXQ
  1. IF $$OLD^SDOEUT(SDOE) S SDOK=$$OLDDX(SDOE) G DXQ
  1. ;
  1. S SDOK=$$DX^PXAPIOE($$VIEN^SDOEUT(.SDOE),$G(SDERR))
  1. DXQ Q SDOK
  1. ;
  1. ;
  1. GETDX(SDOE,SDDX,SDERR) ; -- SDOE GET DIAGNOSES
  1. ; API ID: 56
  1. ;
  1. ;
  1. GETDXG ; -- goto entry point
  1. ;
  1. ; -- do validation checks
  1. IF '$$VALOE^SDOEOE(.SDOE,$G(SDERR)) G GETDXQ
  1. IF $$OLD^SDOEUT(SDOE) D OLDDXS(SDOE,.SDDX) G GETDXQ
  1. ;
  1. D GETDX^PXAPIOE($$VIEN^SDOEUT(.SDOE),.SDDX,$G(SDERR))
  1. GETDXQ Q
  1. ;
  1. ;
  1. FINDDX(SDOE,SDDXID,SDERR) ; -- SDOE FIND DIAGNOSIS
  1. ; API ID: 70
  1. ;
  1. ;
  1. N SDDXS,SDOK,I,SDOEDT
  1. S SDDXS="SDDXS"
  1. ;
  1. ;get encounter date to pass to $$VALDX - SD*5.3*586
  1. S SDOEDT=$P($$GET1^DIQ(409.68,SDOE_",",.01,"I"),".",1)
  1. ; -- do validation checks
  1. IF '$$VALDX(.SDDXID,SDOEDT,$G(SDERR)) S SDOK=0 G FINDDXQ
  1. ;
  1. D GETDX(.SDOE,.SDDXS,$G(SDERR))
  1. S (I,SDOK)=0
  1. F S I=$O(SDDXS(I)) Q:'I S SDOK=(+SDDXS(I)=SDDXID) Q:SDOK
  1. FINDDXQ Q SDOK
  1. ;
  1. ;
  1. GETPDX(SDOE,SDERR) ; -- SDOE GET PRIMARY DIAGNOSIS
  1. ; API ID: 73
  1. ;
  1. ;
  1. N SDDXS,I,SDPDX,CNT
  1. S SDDXS="SDDXS"
  1. D GETDX(.SDOE,.SDDXS,$G(SDERR))
  1. ;
  1. ; -- how many are primaries / kill secondaries from array
  1. S (CNT,I)=0
  1. 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)
  1. S SDPDX=+$G(SDDXS(+$O(SDDXS(0))))
  1. ;
  1. ; -- check for too many primaries & build error msg
  1. IF CNT>1 D
  1. . N DFN,DFN0,SDIN,SDOUT,Y,I,VA
  1. . ;
  1. . S SDPDX=0
  1. . S DFN=+$P($G(^SCE(+SDOE,0)),"^",2)
  1. . S DFN0=$G(^DPT(DFN,0))
  1. . D PID^VADPT6
  1. . ;
  1. . S SDIN("ID")=SDOE,SDOUT("ID")=SDOE
  1. . S SDIN("DFN")=DFN,SDOUT("DFN")=DFN
  1. . S SDIN("PATNAME")=$P(DFN0,"^"),SDOUT("PATNAME")=$P(DFN0,"^")
  1. . S SDIN("PID")=VA("PID"),SDOUT("PID")=VA("PID")
  1. . ;
  1. . S I=0,Y=""
  1. . F S I=$O(SDDX(I)) Q:'I S Y=$P($G(^ICD9(+SDDXS,0)),"^")_" "
  1. . S SDIN("CODES")=Y,SDOUT("CODES")=Y
  1. . ;
  1. . D BLD^SDQVAL(4096800.025,.SDIN,.SDOUT,$G(SDERR))
  1. ;
  1. GETPDXQ Q SDPDX
  1. ;
  1. ;
  1. VALDX(SDDXID,SDOEDT,SDERR) ; -- validate dx input
  1. ;
  1. ; -- do checks
  1. ;Patch SD*5.3*586
  1. I SDDXID,+$$ICDDX^ICDEX(SDDXID,SDOEDT,+$$SYS^ICDEX("DIAG",SDOEDT,"I"),"I") Q 1
  1. ;
  1. ; -- build error msg
  1. N SDIN,SDOUT
  1. S SDIN("ID")=SDDXID
  1. S SDOUT("ID")=SDDXID
  1. D BLD^SDQVAL(4096800.004,.SDIN,.SDOUT,$G(SDERR))
  1. Q 0
  1. ;
  1. ;
  1. OLDDX(SDOE) ; -- at least one dx for OLD encounter?
  1. Q ($O(^SDD(409.43,"OE",+SDOE,0))>0)
  1. ;
  1. OLDDXS(SDOE,SDARY) ; -- get DX's for OLD encounter
  1. N SDIEN,SDCNT,Y,X
  1. S (SDIEN,SDCNT)=0
  1. F S SDIEN=$O(^SDD(409.43,"OE",SDOE,SDIEN)) Q:'SDIEN D
  1. . S SDCNT=SDCNT+1,X=$G(^SDD(409.43,SDIEN,0))
  1. . S $P(Y,U,1)=+X ; -- dx ien
  1. . S $P(Y,U,12)=$S($P(X,"^",3)=1:"P",1:"S") ; -- primary dx?
  1. . S @SDARY@(SDIEN)=Y
  1. S @SDARY=SDCNT
  1. Q
  1. ;