SDECEP ;SPFO/DMR,PC SCHEDULING ENHANCEMENTS VSE EP API ;Apr 02, 2020@14:27
;;5.3;Scheduling;**669,694**;Aug 13 1993;Build 61
;
;The API provides Extended Profile Appt info the VS Gui.
;INPUT - DFN required
; APP appointment date/time required
Q
;
CLASS(RTT,DFN,APT) ;
Q:'$G(DFN)
Q:'$G(APT)
;
; Each Clasification set to Not Applicable
; 1 Agent Orange Exposure: Not Applicable
; 2 Ionizing Radiation Exposure: Not Applicable
; 3 Treatment for SC Condition: Not Applicable
; 4 SW Asia Conditions: Not Applicable
; 5 Military Sexual Trauma: Not Applicable
; 6 Head and/or Neck Cancer: Not Applicable
; 7 Combat Vet (Combat Related): Not Applicable
;
S APT=+APT ;strip off extra zeros on time pwc SD*5.3*694
;
S NA="Not Applicable"
S RTT=NA_U_NA_U_NA_U_NA_U_NA_U_NA_U_NA_U_NA
;
S (ENCN,CC,CL)=""
;
S ENCN=$P($G(^DPT(DFN,"S",APT,0)),"^",20)
I ENCN'="" D CLOE^SDCO21(ENCN,.RR)
F CC=1:1:8 S CL=$G(RR(CC)) D
.I $P($G(CL),"^",2)=1 S $P(RTT,"^",CC)="YES"
.I $P($G(CL),"^",2)=0 S $P(RTT,"^",CC)="NO"
K ENCN,CC,CL
Q
;
DIAGN(REN,DFN,APP) ;
Q:'$G(DFN)
Q:'$G(APP)
;
S APP=+APP ;strip off extra zeros on time pwc SD*5.3*694
;
S (ENUM,CNT,CNT1,CC,NAME,REN)=""
S ENUM=$P($G(^DPT(DFN,"S",APP,0)),"^",20)
I ENUM'="" D SET^SDCO4(ENUM)
Q:SDCNT=""
F CC=1:1:SDCNT S ICDN=$P($G(SDDXY(CC)),"^",2) D
.Q:ICDN=""
.S NAME="" S NAME=$$GET1^DIQ(80,ICDN,.01)
.S CNT="" S CNT=$P($G(^ICD9(ICDN,67,0)),"^",3)
.S CNT1="" S CNT1=$P(^ICD9(ICDN,67,CNT,0),"^",2)
.S REN=REN_NAME_" "_CNT1_"^"
.Q
K ENUM,CNT,CNT1,CC,NAME
Q
PROV(RET,DFN,APPT) ;
Q:'$G(DFN)
Q:'$G(APPT)
;
S APPT=+APPT ;strip off extra zeros on time pwc SD*5.3*694
;
S EN="" S EN=$P($G(^DPT(DFN,"S",APPT,0)),"^",20)
Q:EN=""
;
S (CC,NAME,NAM,RET)=""
;
K PLIST
D GETPRV^SDOE(EN,"PLIST")
Q:PLIST=""
F S CC=$O(PLIST(CC)) Q:CC="" D
.S NAM="" S NAM=$P(PLIST(CC),"^",1)
.S NAME="" S NAME=$$GET1^DIQ(200,NAM,.01)
.I NAME'="" S RET=RET_NAME_"^"
.Q
K CC,NAME,NAM
Q
;
CPT(REC,DFN,APP) ;
Q:'$G(APP)
Q:'$G(DFN)
;
S APP=+APP ;strip off extra zeros on time pwc SD*5.3*694
;
S ENN="" S ENN=$P($G(^DPT(DFN,"S",APP,0)),"^",20)
Q:ENN=""
S (CNT,CC,CCC,CPT,PNAR,PNARN,QTY,CPTM,REC)=""
;
K CPTL
D GETCPT^SDOE(ENN,"CPTL")
S CC="" F S CC=$O(CPTL(CC)) Q:CC="" D
.S CPT="" S CPT=$P($G(CPTL(CC,0)),"^",1)
.S QTY="" S QTY=$P($G(CPTL(CC,0)),"^",16)
.S PNARN="" S PNARN=$P($G(CPTL(CC,0)),"^",4)
.I PNARN'="" S PNAR="" S PNAR=$$GET1^DIQ(9999999.27,PNARN,.01)
.S REC=REC_"^"_CPT_" "_QTY_" "_PNAR
.I $D(CPTL(CC,1,0)) D
..S (CNN,CMM,CCC)="" S CCC=$P($G(CPTL(CC,1,0)),"^",4)
..F CNT=1:1:CCC S CNN=$P($G(CPTL(CC,1,CNT,0)),"^",1) D
...I CNN>0 D
....S CPTMN="" S CPTMN=$$GET1^DIQ(81.3,CNN,.02)
....S CMM="" S CMM=$$GET1^DIQ(81.3,CNN,.01)
...S CPTM=CPTM_":"_CMM_":"_CPTMN
...S REC=REC_CPTM
...Q
K ENN,CNT,CC,CCC,CPT,PNAR,PNARN,QTY,CPTM
Q
;
SCODE(RTU,DFN,APP) ;
Q:'$G(DFN)
Q:'$G(APP)
;
S APP=+APP ;strip off extra zeros on time pwc SD*5.3*694
;
S ENU="" S ENU=$P($G(^DPT(DFN,"S",APP,0)),"^",20)
Q:ENU=""
S (SNAM,SNUM,SNAM1,SNUM1,LOC,LNUM,AMIS,AMIS1,RTU)=""
;
S LNUM="" S LNUM=$P($G(^SCE(ENU,0)),"^",4)
Q:LNUM=""
S (SNAM,SNUM)="" S SNAM=$$GET1^DIQ(44,LNUM,8,"E") S SNUM=$$GET1^DIQ(44,LNUM,8,"I")
I SNUM'="" S AMIS="" S AMIS=$$GET1^DIQ(40.7,SNUM,1)
S (SNAM1,SNUM1)="" S SNAM1=$$GET1^DIQ(44,LNUM,2503,"E") S SNUM1=$$GET1^DIQ(44,LNUM,2503,"I")
I SNUM1'="" S AMIS1="" S AMIS1=$$GET1^DIQ(40.7,SNUM1,1)
S RTU=AMIS_" "_SNAM_"^"_AMIS1_" "_SNAM1_"^"
K SNAM,SNUM,SNAM1,SNUM1,LOC,LNUM,AMIS,AMIS1
Q
;
INP(REN,DFN) ;
Q:'$G(DFN)
;
S (ADMDT,DISDT,DNUM,LSTAT,SDST,SDSTA,REN)=""
I '$D(^DGPM("C",DFN)) S LSTAT="NO INPT./LOD. ACT." Q
;
S VAIP("D")="L",VAIP("L")="" D INP^DGPMV10
S A=$S("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2)),SDST=$S('A:"IN",1:"")_"ACTIVE ",SDSTA=$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",1:"INPATIENT")
S LSTAT="" S LSTAT=SDST_" "_SDSTA
S ADMDT="" S ADMDT=$P($G(DGPMVI(13,1)),"^",2)
S DNUM="" S DNUM=$G(DGPMV1(17)) I DNUM'="" D
.S DISDT="" S DISDT=$$GET1^DIQ(405,DNUM,.01)
S REN=LSTAT_"^"_ADMDT_"^"_DISDT
K ADMDT,DISDT,DNUM,LSTAT,SDST,SDSTA
Q
APPT(RET,DFN1,APP1) ;
Q:'$G(DFN1)
Q:'$G(APP1)
;
S APP1=+APP1 ;strip off extra zeros on time pwc SD*5.3*694
;
S RET=$P($G(^DPT(DFN1,"S",APP1,0)),"^",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECEP 4394 printed Dec 13, 2024@02:52:02 Page 2
SDECEP ;SPFO/DMR,PC SCHEDULING ENHANCEMENTS VSE EP API ;Apr 02, 2020@14:27
+1 ;;5.3;Scheduling;**669,694**;Aug 13 1993;Build 61
+2 ;
+3 ;The API provides Extended Profile Appt info the VS Gui.
+4 ;INPUT - DFN required
+5 ; APP appointment date/time required
+6 QUIT
+7 ;
CLASS(RTT,DFN,APT) ;
+1 if '$GET(DFN)
QUIT
+2 if '$GET(APT)
QUIT
+3 ;
+4 ; Each Clasification set to Not Applicable
+5 ; 1 Agent Orange Exposure: Not Applicable
+6 ; 2 Ionizing Radiation Exposure: Not Applicable
+7 ; 3 Treatment for SC Condition: Not Applicable
+8 ; 4 SW Asia Conditions: Not Applicable
+9 ; 5 Military Sexual Trauma: Not Applicable
+10 ; 6 Head and/or Neck Cancer: Not Applicable
+11 ; 7 Combat Vet (Combat Related): Not Applicable
+12 ;
+13 ;strip off extra zeros on time pwc SD*5.3*694
SET APT=+APT
+14 ;
+15 SET NA="Not Applicable"
+16 SET RTT=NA_U_NA_U_NA_U_NA_U_NA_U_NA_U_NA_U_NA
+17 ;
+18 SET (ENCN,CC,CL)=""
+19 ;
+20 SET ENCN=$PIECE($GET(^DPT(DFN,"S",APT,0)),"^",20)
+21 IF ENCN'=""
DO CLOE^SDCO21(ENCN,.RR)
+22 FOR CC=1:1:8
SET CL=$GET(RR(CC))
Begin DoDot:1
+23 IF $PIECE($GET(CL),"^",2)=1
SET $PIECE(RTT,"^",CC)="YES"
+24 IF $PIECE($GET(CL),"^",2)=0
SET $PIECE(RTT,"^",CC)="NO"
End DoDot:1
+25 KILL ENCN,CC,CL
+26 QUIT
+27 ;
DIAGN(REN,DFN,APP) ;
+1 if '$GET(DFN)
QUIT
+2 if '$GET(APP)
QUIT
+3 ;
+4 ;strip off extra zeros on time pwc SD*5.3*694
SET APP=+APP
+5 ;
+6 SET (ENUM,CNT,CNT1,CC,NAME,REN)=""
+7 SET ENUM=$PIECE($GET(^DPT(DFN,"S",APP,0)),"^",20)
+8 IF ENUM'=""
DO SET^SDCO4(ENUM)
+9 if SDCNT=""
QUIT
+10 FOR CC=1:1:SDCNT
SET ICDN=$PIECE($GET(SDDXY(CC)),"^",2)
Begin DoDot:1
+11 if ICDN=""
QUIT
+12 SET NAME=""
SET NAME=$$GET1^DIQ(80,ICDN,.01)
+13 SET CNT=""
SET CNT=$PIECE($GET(^ICD9(ICDN,67,0)),"^",3)
+14 SET CNT1=""
SET CNT1=$PIECE(^ICD9(ICDN,67,CNT,0),"^",2)
+15 SET REN=REN_NAME_" "_CNT1_"^"
+16 QUIT
End DoDot:1
+17 KILL ENUM,CNT,CNT1,CC,NAME
+18 QUIT
PROV(RET,DFN,APPT) ;
+1 if '$GET(DFN)
QUIT
+2 if '$GET(APPT)
QUIT
+3 ;
+4 ;strip off extra zeros on time pwc SD*5.3*694
SET APPT=+APPT
+5 ;
+6 SET EN=""
SET EN=$PIECE($GET(^DPT(DFN,"S",APPT,0)),"^",20)
+7 if EN=""
QUIT
+8 ;
+9 SET (CC,NAME,NAM,RET)=""
+10 ;
+11 KILL PLIST
+12 DO GETPRV^SDOE(EN,"PLIST")
+13 if PLIST=""
QUIT
+14 FOR
SET CC=$ORDER(PLIST(CC))
if CC=""
QUIT
Begin DoDot:1
+15 SET NAM=""
SET NAM=$PIECE(PLIST(CC),"^",1)
+16 SET NAME=""
SET NAME=$$GET1^DIQ(200,NAM,.01)
+17 IF NAME'=""
SET RET=RET_NAME_"^"
+18 QUIT
End DoDot:1
+19 KILL CC,NAME,NAM
+20 QUIT
+21 ;
CPT(REC,DFN,APP) ;
+1 if '$GET(APP)
QUIT
+2 if '$GET(DFN)
QUIT
+3 ;
+4 ;strip off extra zeros on time pwc SD*5.3*694
SET APP=+APP
+5 ;
+6 SET ENN=""
SET ENN=$PIECE($GET(^DPT(DFN,"S",APP,0)),"^",20)
+7 if ENN=""
QUIT
+8 SET (CNT,CC,CCC,CPT,PNAR,PNARN,QTY,CPTM,REC)=""
+9 ;
+10 KILL CPTL
+11 DO GETCPT^SDOE(ENN,"CPTL")
+12 SET CC=""
FOR
SET CC=$ORDER(CPTL(CC))
if CC=""
QUIT
Begin DoDot:1
+13 SET CPT=""
SET CPT=$PIECE($GET(CPTL(CC,0)),"^",1)
+14 SET QTY=""
SET QTY=$PIECE($GET(CPTL(CC,0)),"^",16)
+15 SET PNARN=""
SET PNARN=$PIECE($GET(CPTL(CC,0)),"^",4)
+16 IF PNARN'=""
SET PNAR=""
SET PNAR=$$GET1^DIQ(9999999.27,PNARN,.01)
+17 SET REC=REC_"^"_CPT_" "_QTY_" "_PNAR
+18 IF $DATA(CPTL(CC,1,0))
Begin DoDot:2
+19 SET (CNN,CMM,CCC)=""
SET CCC=$PIECE($GET(CPTL(CC,1,0)),"^",4)
+20 FOR CNT=1:1:CCC
SET CNN=$PIECE($GET(CPTL(CC,1,CNT,0)),"^",1)
Begin DoDot:3
+21 IF CNN>0
Begin DoDot:4
+22 SET CPTMN=""
SET CPTMN=$$GET1^DIQ(81.3,CNN,.02)
+23 SET CMM=""
SET CMM=$$GET1^DIQ(81.3,CNN,.01)
End DoDot:4
+24 SET CPTM=CPTM_":"_CMM_":"_CPTMN
+25 SET REC=REC_CPTM
+26 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+27 KILL ENN,CNT,CC,CCC,CPT,PNAR,PNARN,QTY,CPTM
+28 QUIT
+29 ;
SCODE(RTU,DFN,APP) ;
+1 if '$GET(DFN)
QUIT
+2 if '$GET(APP)
QUIT
+3 ;
+4 ;strip off extra zeros on time pwc SD*5.3*694
SET APP=+APP
+5 ;
+6 SET ENU=""
SET ENU=$PIECE($GET(^DPT(DFN,"S",APP,0)),"^",20)
+7 if ENU=""
QUIT
+8 SET (SNAM,SNUM,SNAM1,SNUM1,LOC,LNUM,AMIS,AMIS1,RTU)=""
+9 ;
+10 SET LNUM=""
SET LNUM=$PIECE($GET(^SCE(ENU,0)),"^",4)
+11 if LNUM=""
QUIT
+12 SET (SNAM,SNUM)=""
SET SNAM=$$GET1^DIQ(44,LNUM,8,"E")
SET SNUM=$$GET1^DIQ(44,LNUM,8,"I")
+13 IF SNUM'=""
SET AMIS=""
SET AMIS=$$GET1^DIQ(40.7,SNUM,1)
+14 SET (SNAM1,SNUM1)=""
SET SNAM1=$$GET1^DIQ(44,LNUM,2503,"E")
SET SNUM1=$$GET1^DIQ(44,LNUM,2503,"I")
+15 IF SNUM1'=""
SET AMIS1=""
SET AMIS1=$$GET1^DIQ(40.7,SNUM1,1)
+16 SET RTU=AMIS_" "_SNAM_"^"_AMIS1_" "_SNAM1_"^"
+17 KILL SNAM,SNUM,SNAM1,SNUM1,LOC,LNUM,AMIS,AMIS1
+18 QUIT
+19 ;
INP(REN,DFN) ;
+1 if '$GET(DFN)
QUIT
+2 ;
+3 SET (ADMDT,DISDT,DNUM,LSTAT,SDST,SDSTA,REN)=""
+4 IF '$DATA(^DGPM("C",DFN))
SET LSTAT="NO INPT./LOD. ACT."
QUIT
+5 ;
+6 SET VAIP("D")="L"
SET VAIP("L")=""
DO INP^DGPMV10
+7 SET A=$SELECT("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2))
SET SDST=$SELECT('A:"IN",1:"")_"ACTIVE "
SET SDSTA=$SELECT("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",1:"INPATIENT")
+8 SET LSTAT=""
SET LSTAT=SDST_" "_SDSTA
+9 SET ADMDT=""
SET ADMDT=$PIECE($GET(DGPMVI(13,1)),"^",2)
+10 SET DNUM=""
SET DNUM=$GET(DGPMV1(17))
IF DNUM'=""
Begin DoDot:1
+11 SET DISDT=""
SET DISDT=$$GET1^DIQ(405,DNUM,.01)
End DoDot:1
+12 SET REN=LSTAT_"^"_ADMDT_"^"_DISDT
+13 KILL ADMDT,DISDT,DNUM,LSTAT,SDST,SDSTA
+14 QUIT
APPT(RET,DFN1,APP1) ;
+1 if '$GET(DFN1)
QUIT
+2 if '$GET(APP1)
QUIT
+3 ;
+4 ;strip off extra zeros on time pwc SD*5.3*694
SET APP1=+APP1
+5 ;
+6 SET RET=$PIECE($GET(^DPT(DFN1,"S",APP1,0)),"^",2)
+7 QUIT
