- 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 Jan 18, 2025@03:53:10 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