- SDECCON ;SPFO/DMR,MGD,RRM SCHEDULING ENHANCEMENTS VSE CONTACT API ;Mar 31, 2021@09:59
- ;;5.3;Scheduling;**669,686,781,785,827**;Aug 13 1993;Build 10
- ;
- ;This API provides SDEC CONTACT(#409.86)file information to the VSE VS GUI.
- ; 3/6/18 - wtc/zeb Added new cross-reference for audit statistics compiler. Patch 686
- ;
- Q
- DISPLAY(RTU,DFN,CLN,PDT,REQT,SER) ;
- ; RPC: SDEC CONTACT DISPLAY
- Q:'$G(DFN)
- Q:'$G(PDT)
- Q:'$D(REQT)
- S (CC,CC1,CC2,REC)=""
- ;
- S PDT=$$NETTOFM^SDECDATE(PDT,"N","N") ;CONVERT TO FILEMAN DATE
- ;
- S CC="" F S CC=$O(^SDEC(409.86,"B",DFN,CC)) Q:CC="" D
- .S REC="" S REC=^SDEC(409.86,CC,0)
- .Q:PDT'=$P($G(REC),"^",3)
- .I $G(CLN)'="" Q:$G(CLN)'=$P($G(REC),"^",2)
- .I $G(SER)'="" Q:$G(SER)'=$P($G(REC),"^",6)
- .Q:REQT'=$P($G(REC),"^",4)
- .S RTU=CC_"^"_REC
- .Q
- D EXIT
- Q
- ;
- DISPLAY1(RTU,REQT,RIEN) ;
- ; RPC: SDEC CONTACT DISPLAY SINGLE
- ; INPUT: REQT = Request Type: SDEC CONTACT, REQUEST/CONSULTATION or SDEC APPT REQUEST
- ; RIEN = IEN of the record of interest
- ; OUTPUT:
- ; 1st ^ Piece = IEN of VistA record identified
- ; 2nd ^ Piece = 0 node of File #409.86 for the identified record
- ;
- I $G(RTU)="" S RTU=0
- Q:REQT=""!("^R^A^RTC^C^P^V^"'[("^"_REQT_"^"))
- Q:RIEN=""
- ;
- S (CC,ROOT,REC,GMR,AR40985,RECALL)=""
- ; $O backwards to get the last entry entered if there are more than one entry in the x-ref
- S CC=$O(^SDEC(409.86,"SRP",RIEN,""),-1)
- I CC<1 D EXIT Q
- S ROOT="" S ROOT=$P(^SDEC(409.86,CC,0),"^",7)
- Q:$P(ROOT,";",1)'=RIEN
- ; Load 0 node for return
- S REC="" S REC=^SDEC(409.86,CC,0)
- ; Check for SDEC CONTACT
- I REQT="R" D
- .S RECALL="" S RECALL=$G(^SD(403.5,RIEN,0))
- .Q:RECALL=""
- .Q:$P(REC,"^",1)'=$P(RECALL,"^",1)
- .S RTU=CC_"^"_REC
- .Q
- ; Check for SDEC APPT REQUEST
- I (REQT="A")!(REQT="RTC")!(REQT="V") D
- .S AR40985="" S AR40985=$G(^SDEC(409.85,RIEN,0))
- .Q:AR40985=""
- .Q:$P(REC,"^",1)'=$P(AR40985,"^",1)
- .S RTU=CC_"^"_REC
- .Q
- ; Check for REQUEST/CONSULTATION
- I REQT="C"!(REQT="P") D
- .S GMR="" S GMR=$G(^GMR(123,RIEN,0))
- .Q:GMR=""
- .Q:$P(REC,"^",1)'=$P(GMR,"^",2)
- .Q:$P($G(REC),"^",1)'=$P($G(GMR),"^",2)
- .S RTU=CC_"^"_REC
- .Q
- D EXIT
- Q
- ;
- DISMULT(RTT,CIEN) ;
- ; RPC: SDEC CONTACT MULTI-DISPLAY
- Q:'$G(CIEN)
- ;
- S (CC1,CC2,REC1,REC2,RTT,ENDT)=""
- ;
- S CC2="" F S CC2=$O(^SDEC(409.86,CIEN,1,CC2)) Q:CC2="" D
- .S REC2="" S REC2=$G(^SDEC(409.86,CIEN,1,CC2,1)) Q:REC2="" D
- ..S ENDT="" S ENDT=$P($G(^SDEC(409.86,CIEN,1,CC2,0)),"^",1)
- ..S (ENTU,ENTUN)="" S ENTUN=$P(REC2,"^",5) I ENTUN>0 D
- ...S ENTU=$$GET1^DIQ(200,ENTUN,.01,"E")
- ..S RTT=RTT_CC1_"^"_REC2_"^"_ENTU_"^"_ENDT_";"
- ..Q
- D EXIT
- Q
- ;
- NEW(RET,DFN,CLI,DTP,REQT,SRV,DTCON,CONT,COM,DTENT,RIEN) ;
- ; RPC: SDEC CONTACT NEW
- S RET=0
- Q:'$G(DFN)
- Q:'$G(DTP)
- Q:'$D(REQT)
- Q:'$G(DTCON)
- Q:'$D(CONT)
- Q:'$G(DTENT)
- Q:'$G(RIEN)
- I '$D(COM) S COM=""
- I '$G(CLI) S CLI=""
- I '$G(SRV) S SRV=""
- S DTP=$$NETTOFM^SDECDATE(DTP,"N","N") ;CONVERT TO FILEMAN DATE
- ;
- ; Determine variable pointer file
- S SDRIEN=""
- I RIEN>0 D
- . I (REQT="A")!(REQT="RTC")!(REQT="V") D
- . . Q:$P($G(^SDEC(409.85,RIEN,0)),U,1)'=DFN
- . . Q:($P($G(^SDEC(409.85,RIEN,0)),U,5)'="APPT"&($P($G(^SDEC(409.85,RIEN,0)),U,5)'="RTC"))&($P($G(^SDEC(409.85,RIEN,0)),U,5)'="VETERAN")
- . . S SDRIEN=RIEN_";"_"SDEC(409.85," Q
- . Q:SDRIEN'=""
- . I REQT="C"!(REQT="P") D
- . . Q:$P($G(^GMR(123,RIEN,0)),U,2)'=DFN
- . . Q:$P($G(^GMR(123,RIEN,0)),U,17)'=REQT
- . . Q:CLI'=""&(CLI'=$P(^GMR(123,RIEN,0),U,4))
- . . S SDRIEN=RIEN_";"_"GMR(123," Q
- . Q:SDRIEN'=""
- . I REQT="R" D
- . . Q:$P($G(^SD(403.5,RIEN,0)),U,1)'=DFN
- . . Q:$P($G(^SD(403.5,RIEN,0)),U,2)'=CLI
- . . S SDRIEN=RIEN_";"_"SD(403.5,"
- . Q
- ;
- S (DFN2,CC1,CC2)=""
- ;
- S DFN2="" F S DFN2=$O(^SDEC(409.86,"B",DFN2)) Q:DFN2="" D
- .S CC1="" F S CC1=$O(^SDEC(409.86,"B",DFN2,CC1)) Q:CC1="" D
- ..S CC2=CC2+1
- ..Q
- S CC2=CC2+1 D
- .S ^SDEC(409.86,0)="SDEC CONTACT^409.86P^"_CC2_"^"_CC2
- .S ^SDEC(409.86,CC2,0)=DFN_"^"_CLI_"^"_DTP_"^"_REQT_"^"_1_"^"_SRV
- .S ^SDEC(409.86,CC2,1,0)="^409.863D^1^1"
- .S ^SDEC(409.86,CC2,1,1,0)=DTCON
- .S ^SDEC(409.86,CC2,1,1,1)=CONT_"^"_COM_"^"_0_"^"_1_"^"_DUZ_"^"_DTENT
- .S ^SDEC(409.86,"B",DFN,CC2)=""
- .S ^SDEC(409.86,CC2,1,"B",DTCON,1)=""
- .S ^SDEC(409.86,"AD",DTENT,DUZ,CC2,1)="" ; 3/6/18 WTC/ZEB create date/user cross-reference.
- .I SDRIEN'="" S $P(^SDEC(409.86,CC2,0),U,7)=SDRIEN ; APPT REQUEST TYPE (#2.3)
- .; Build the SRP x-ref
- .N DIK,DA
- .S DIK="^SDEC(409.86,",DA=CC2,DIK(1)=2.3
- .D EN1^DIK
- .Q
- S RET=1
- D EXIT
- Q
- SEQ(RE1,DF1,CL1,PDATE,RTYPE,SRR) ;
- ; RPC: SDEC CONTACT SEQUENCE
- Q:'$G(DF1)
- Q:'$G(PDATE)
- I '$G(CL1) S CL1=""
- I '$G(SRR) S SRR=""
- ;
- S (JJ,JJ1,RCD,SQU,DF2)=""
- S PDATE=$$NETTOFM^SDECDATE(PDATE,"N","N")
- ;
- S JJ="" F S JJ=$O(^SDEC(409.86,"B",DF1,JJ)) Q:JJ="" D
- .S RCD="" S RCD=$G(^SDEC(409.86,JJ,0)) Q:RCD="" D
- ..S SQU="" S SQU=$P($G(^SDEC(409.86,JJ,1,0)),"^",3) D
- ...Q:$G(SQU)=""
- ...Q:PDATE'=$P($G(RCD),"^",3)
- ...Q:RTYPE'=$P($G(RCD),"^",4)
- ...I $P($G(RCD),"^",2)=CL1 D
- ....S $P(^SDEC(409.86,JJ,0),"^",5)=SQU+1
- ....S RE1=SQU+1
- ....Q
- ...I $P($G(RCD),"^",6)=SRR D
- ....S $P(^SDEC(409.86,JJ,0),"^",5)=SQU+1
- ....S RE1=SQU+1
- ....Q
- D EXIT
- Q
- ;
- SEQ1(RTU,REQT,RIEN) ;
- ; RPC: SDEC CONTACT SEQUENCE SINGLE
- ; INPUT: REQT = Request Type: SDEC CONTACT, REQUEST/CONSULTATION or SDEC APPT REQUEST
- ; RIEN = IEN of the record of interest
- ; OUTPUT:
- ; RTU = Newly created contact sequence number
- I $G(RTU)="" S RTU=0
- Q:REQT=""!("^R^A^RTC^C^P^V^"'[("^"_REQT_"^"))
- Q:RIEN=""
- ;
- ; $O backwards to get the last entry entered if there are more than one entry in the x-ref
- S CC=$O(^SDEC(409.86,"SRP",RIEN,""),-1)
- I CC<1 D EXIT Q
- S RCD=$G(^SDEC(409.86,CC,0)) Q:RCD=""
- S SQU="" S SQU=$P($G(^SDEC(409.86,CC,1,0)),"^",3)
- Q:$G(SQU)=""
- Q:REQT'=$P($G(RCD),"^",4)
- S RE1=SQU+1
- S $P(^SDEC(409.86,CC,0),"^",5)=RE1
- Q
- ;
- UPDATE(RTT,IEN,CONDT,CTYPE,COMM,DTEN) ;
- ; RPC: SDEC CONTACT UPDATE
- Q:'$G(IEN)
- Q:'$G(CONDT)
- Q:'$D(CTYPE)
- I '$D(COMM) S COMM=""
- I '$G(DTEN) S DTEN=""
- ;
- S (MULT,RTT,CC,CCC,COUNT,MULTN)=""
- ;
- S MULT="" S MULT=$G(^SDEC(409.86,IEN,1,0)) I MULT'="" D
- .S MULTN=$P(MULT,"^",4) I MULTN'="" D
- ..S COUNT=MULTN
- .Q
- I COUNT'="" S COUNT=COUNT+1 D
- .S ^SDEC(409.86,IEN,1,0)="^409.863D^"_COUNT_"^"_COUNT
- .S ^SDEC(409.86,IEN,1,COUNT,0)=CONDT
- .S ^SDEC(409.86,IEN,1,COUNT,1)=CTYPE_"^"_COMM_"^"_0_"^"_COUNT_"^"_DUZ_"^"_DTEN
- .S ^SDEC(409.86,IEN,1,"B",CONDT,COUNT)=""
- .S ^SDEC(409.86,"AD",DTEN,DUZ,IEN,COUNT)="" ; 3/6/18 WTC/ZEB create date/user cross-reference.
- .Q
- D EXIT
- Q
- GETSTC(RET,CLIEN) ;
- ; RPC: SDEC CONTACT STOP CODE
- Q:CLIEN=""
- ;
- ;CLIEN=Clinic IEN
- ;HLF0=Hospital Location File 0 node
- ;SNUM=Stopc Code IEN [0,7]
- ;STPC=Stop Code 40.7
- ;CSNUM=Credit Stop IEN [0,18]
- ;CSTPC=Credit Stop Code 40.7
- ;
- S (HLF0,SNUM,STPC,CSNUM,CSTPC,CNUM)=""
- ;
- S HLF0=$G(^SC(CLIEN,0)) I HLF0'="" D
- .S SNUM=$P($G(HLF0),"^",7) I SNUM'="" D
- ..S STPC=$$GET1^DIQ(40.7,SNUM,1)
- .S CNUM=$P($G(HLF0),"^",18) I CNUM'="" D
- ..S CSTPC=$$GET1^DIQ(40.7,CNUM,1)
- S RET=STPC_"^"_CSTPC
- K HLF0,SNUM,STPC,CSNUM,CSTPC,CNUM
- Q
- EXIT ;
- K MULT,CC,CCC,COUNT,COMM,DTEN,ENDT,AR40985,RECALL,ROOT,GMR
- K JJ,JJ1,RCD,SQU,DF2,DFN2,CC1,CC2,RCD,SQU,ENTU,ENTUN
- K REC,REC1,REC2,ENDT,MULTN,CLN,PDT,REQT,SER,RIEN,SDRIEN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECCON 7344 printed Feb 19, 2025@00:18:17 Page 2
- SDECCON ;SPFO/DMR,MGD,RRM SCHEDULING ENHANCEMENTS VSE CONTACT API ;Mar 31, 2021@09:59
- +1 ;;5.3;Scheduling;**669,686,781,785,827**;Aug 13 1993;Build 10
- +2 ;
- +3 ;This API provides SDEC CONTACT(#409.86)file information to the VSE VS GUI.
- +4 ; 3/6/18 - wtc/zeb Added new cross-reference for audit statistics compiler. Patch 686
- +5 ;
- +6 QUIT
- DISPLAY(RTU,DFN,CLN,PDT,REQT,SER) ;
- +1 ; RPC: SDEC CONTACT DISPLAY
- +2 if '$GET(DFN)
- QUIT
- +3 if '$GET(PDT)
- QUIT
- +4 if '$DATA(REQT)
- QUIT
- +5 SET (CC,CC1,CC2,REC)=""
- +6 ;
- +7 ;CONVERT TO FILEMAN DATE
- SET PDT=$$NETTOFM^SDECDATE(PDT,"N","N")
- +8 ;
- +9 SET CC=""
- FOR
- SET CC=$ORDER(^SDEC(409.86,"B",DFN,CC))
- if CC=""
- QUIT
- Begin DoDot:1
- +10 SET REC=""
- SET REC=^SDEC(409.86,CC,0)
- +11 if PDT'=$PIECE($GET(REC),"^",3)
- QUIT
- +12 IF $GET(CLN)'=""
- if $GET(CLN)'=$PIECE($GET(REC),"^",2)
- QUIT
- +13 IF $GET(SER)'=""
- if $GET(SER)'=$PIECE($GET(REC),"^",6)
- QUIT
- +14 if REQT'=$PIECE($GET(REC),"^",4)
- QUIT
- +15 SET RTU=CC_"^"_REC
- +16 QUIT
- End DoDot:1
- +17 DO EXIT
- +18 QUIT
- +19 ;
- DISPLAY1(RTU,REQT,RIEN) ;
- +1 ; RPC: SDEC CONTACT DISPLAY SINGLE
- +2 ; INPUT: REQT = Request Type: SDEC CONTACT, REQUEST/CONSULTATION or SDEC APPT REQUEST
- +3 ; RIEN = IEN of the record of interest
- +4 ; OUTPUT:
- +5 ; 1st ^ Piece = IEN of VistA record identified
- +6 ; 2nd ^ Piece = 0 node of File #409.86 for the identified record
- +7 ;
- +8 IF $GET(RTU)=""
- SET RTU=0
- +9 if REQT=""!("^R^A^RTC^C^P^V^"'[("^"_REQT_"^"))
- QUIT
- +10 if RIEN=""
- QUIT
- +11 ;
- +12 SET (CC,ROOT,REC,GMR,AR40985,RECALL)=""
- +13 ; $O backwards to get the last entry entered if there are more than one entry in the x-ref
- +14 SET CC=$ORDER(^SDEC(409.86,"SRP",RIEN,""),-1)
- +15 IF CC<1
- DO EXIT
- QUIT
- +16 SET ROOT=""
- SET ROOT=$PIECE(^SDEC(409.86,CC,0),"^",7)
- +17 if $PIECE(ROOT,";",1)'=RIEN
- QUIT
- +18 ; Load 0 node for return
- +19 SET REC=""
- SET REC=^SDEC(409.86,CC,0)
- +20 ; Check for SDEC CONTACT
- +21 IF REQT="R"
- Begin DoDot:1
- +22 SET RECALL=""
- SET RECALL=$GET(^SD(403.5,RIEN,0))
- +23 if RECALL=""
- QUIT
- +24 if $PIECE(REC,"^",1)'=$PIECE(RECALL,"^",1)
- QUIT
- +25 SET RTU=CC_"^"_REC
- +26 QUIT
- End DoDot:1
- +27 ; Check for SDEC APPT REQUEST
- +28 IF (REQT="A")!(REQT="RTC")!(REQT="V")
- Begin DoDot:1
- +29 SET AR40985=""
- SET AR40985=$GET(^SDEC(409.85,RIEN,0))
- +30 if AR40985=""
- QUIT
- +31 if $PIECE(REC,"^",1)'=$PIECE(AR40985,"^",1)
- QUIT
- +32 SET RTU=CC_"^"_REC
- +33 QUIT
- End DoDot:1
- +34 ; Check for REQUEST/CONSULTATION
- +35 IF REQT="C"!(REQT="P")
- Begin DoDot:1
- +36 SET GMR=""
- SET GMR=$GET(^GMR(123,RIEN,0))
- +37 if GMR=""
- QUIT
- +38 if $PIECE(REC,"^",1)'=$PIECE(GMR,"^",2)
- QUIT
- +39 if $PIECE($GET(REC),"^",1)'=$PIECE($GET(GMR),"^",2)
- QUIT
- +40 SET RTU=CC_"^"_REC
- +41 QUIT
- End DoDot:1
- +42 DO EXIT
- +43 QUIT
- +44 ;
- DISMULT(RTT,CIEN) ;
- +1 ; RPC: SDEC CONTACT MULTI-DISPLAY
- +2 if '$GET(CIEN)
- QUIT
- +3 ;
- +4 SET (CC1,CC2,REC1,REC2,RTT,ENDT)=""
- +5 ;
- +6 SET CC2=""
- FOR
- SET CC2=$ORDER(^SDEC(409.86,CIEN,1,CC2))
- if CC2=""
- QUIT
- Begin DoDot:1
- +7 SET REC2=""
- SET REC2=$GET(^SDEC(409.86,CIEN,1,CC2,1))
- if REC2=""
- QUIT
- Begin DoDot:2
- +8 SET ENDT=""
- SET ENDT=$PIECE($GET(^SDEC(409.86,CIEN,1,CC2,0)),"^",1)
- +9 SET (ENTU,ENTUN)=""
- SET ENTUN=$PIECE(REC2,"^",5)
- IF ENTUN>0
- Begin DoDot:3
- +10 SET ENTU=$$GET1^DIQ(200,ENTUN,.01,"E")
- End DoDot:3
- +11 SET RTT=RTT_CC1_"^"_REC2_"^"_ENTU_"^"_ENDT_";"
- +12 QUIT
- End DoDot:2
- End DoDot:1
- +13 DO EXIT
- +14 QUIT
- +15 ;
- NEW(RET,DFN,CLI,DTP,REQT,SRV,DTCON,CONT,COM,DTENT,RIEN) ;
- +1 ; RPC: SDEC CONTACT NEW
- +2 SET RET=0
- +3 if '$GET(DFN)
- QUIT
- +4 if '$GET(DTP)
- QUIT
- +5 if '$DATA(REQT)
- QUIT
- +6 if '$GET(DTCON)
- QUIT
- +7 if '$DATA(CONT)
- QUIT
- +8 if '$GET(DTENT)
- QUIT
- +9 if '$GET(RIEN)
- QUIT
- +10 IF '$DATA(COM)
- SET COM=""
- +11 IF '$GET(CLI)
- SET CLI=""
- +12 IF '$GET(SRV)
- SET SRV=""
- +13 ;CONVERT TO FILEMAN DATE
- SET DTP=$$NETTOFM^SDECDATE(DTP,"N","N")
- +14 ;
- +15 ; Determine variable pointer file
- +16 SET SDRIEN=""
- +17 IF RIEN>0
- Begin DoDot:1
- +18 IF (REQT="A")!(REQT="RTC")!(REQT="V")
- Begin DoDot:2
- +19 if $PIECE($GET(^SDEC(409.85,RIEN,0)),U,1)'=DFN
- QUIT
- +20 if ($PIECE($GET(^SDEC(409.85,RIEN,0)),U,5)'="APPT"&($PIECE($GET(^SDEC(409.85,RIEN,0)),U,5)'="RTC"))&($PIECE($GET(^SDEC(409.85,RIEN,0)),U,5)'="VETERAN")
- QUIT
- +21 SET SDRIEN=RIEN_";"_"SDEC(409.85,"
- QUIT
- End DoDot:2
- +22 if SDRIEN'=""
- QUIT
- +23 IF REQT="C"!(REQT="P")
- Begin DoDot:2
- +24 if $PIECE($GET(^GMR(123,RIEN,0)),U,2)'=DFN
- QUIT
- +25 if $PIECE($GET(^GMR(123,RIEN,0)),U,17)'=REQT
- QUIT
- +26 if CLI'=""&(CLI'=$PIECE(^GMR(123,RIEN,0),U,4))
- QUIT
- +27 SET SDRIEN=RIEN_";"_"GMR(123,"
- QUIT
- End DoDot:2
- +28 if SDRIEN'=""
- QUIT
- +29 IF REQT="R"
- Begin DoDot:2
- +30 if $PIECE($GET(^SD(403.5,RIEN,0)),U,1)'=DFN
- QUIT
- +31 if $PIECE($GET(^SD(403.5,RIEN,0)),U,2)'=CLI
- QUIT
- +32 SET SDRIEN=RIEN_";"_"SD(403.5,"
- End DoDot:2
- +33 QUIT
- End DoDot:1
- +34 ;
- +35 SET (DFN2,CC1,CC2)=""
- +36 ;
- +37 SET DFN2=""
- FOR
- SET DFN2=$ORDER(^SDEC(409.86,"B",DFN2))
- if DFN2=""
- QUIT
- Begin DoDot:1
- +38 SET CC1=""
- FOR
- SET CC1=$ORDER(^SDEC(409.86,"B",DFN2,CC1))
- if CC1=""
- QUIT
- Begin DoDot:2
- +39 SET CC2=CC2+1
- +40 QUIT
- End DoDot:2
- End DoDot:1
- +41 SET CC2=CC2+1
- Begin DoDot:1
- +42 SET ^SDEC(409.86,0)="SDEC CONTACT^409.86P^"_CC2_"^"_CC2
- +43 SET ^SDEC(409.86,CC2,0)=DFN_"^"_CLI_"^"_DTP_"^"_REQT_"^"_1_"^"_SRV
- +44 SET ^SDEC(409.86,CC2,1,0)="^409.863D^1^1"
- +45 SET ^SDEC(409.86,CC2,1,1,0)=DTCON
- +46 SET ^SDEC(409.86,CC2,1,1,1)=CONT_"^"_COM_"^"_0_"^"_1_"^"_DUZ_"^"_DTENT
- +47 SET ^SDEC(409.86,"B",DFN,CC2)=""
- +48 SET ^SDEC(409.86,CC2,1,"B",DTCON,1)=""
- +49 ; 3/6/18 WTC/ZEB create date/user cross-reference.
- SET ^SDEC(409.86,"AD",DTENT,DUZ,CC2,1)=""
- +50 ; APPT REQUEST TYPE (#2.3)
- IF SDRIEN'=""
- SET $PIECE(^SDEC(409.86,CC2,0),U,7)=SDRIEN
- +51 ; Build the SRP x-ref
- +52 NEW DIK,DA
- +53 SET DIK="^SDEC(409.86,"
- SET DA=CC2
- SET DIK(1)=2.3
- +54 DO EN1^DIK
- +55 QUIT
- End DoDot:1
- +56 SET RET=1
- +57 DO EXIT
- +58 QUIT
- SEQ(RE1,DF1,CL1,PDATE,RTYPE,SRR) ;
- +1 ; RPC: SDEC CONTACT SEQUENCE
- +2 if '$GET(DF1)
- QUIT
- +3 if '$GET(PDATE)
- QUIT
- +4 IF '$GET(CL1)
- SET CL1=""
- +5 IF '$GET(SRR)
- SET SRR=""
- +6 ;
- +7 SET (JJ,JJ1,RCD,SQU,DF2)=""
- +8 SET PDATE=$$NETTOFM^SDECDATE(PDATE,"N","N")
- +9 ;
- +10 SET JJ=""
- FOR
- SET JJ=$ORDER(^SDEC(409.86,"B",DF1,JJ))
- if JJ=""
- QUIT
- Begin DoDot:1
- +11 SET RCD=""
- SET RCD=$GET(^SDEC(409.86,JJ,0))
- if RCD=""
- QUIT
- Begin DoDot:2
- +12 SET SQU=""
- SET SQU=$PIECE($GET(^SDEC(409.86,JJ,1,0)),"^",3)
- Begin DoDot:3
- +13 if $GET(SQU)=""
- QUIT
- +14 if PDATE'=$PIECE($GET(RCD),"^",3)
- QUIT
- +15 if RTYPE'=$PIECE($GET(RCD),"^",4)
- QUIT
- +16 IF $PIECE($GET(RCD),"^",2)=CL1
- Begin DoDot:4
- +17 SET $PIECE(^SDEC(409.86,JJ,0),"^",5)=SQU+1
- +18 SET RE1=SQU+1
- +19 QUIT
- End DoDot:4
- +20 IF $PIECE($GET(RCD),"^",6)=SRR
- Begin DoDot:4
- +21 SET $PIECE(^SDEC(409.86,JJ,0),"^",5)=SQU+1
- +22 SET RE1=SQU+1
- +23 QUIT
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 DO EXIT
- +25 QUIT
- +26 ;
- SEQ1(RTU,REQT,RIEN) ;
- +1 ; RPC: SDEC CONTACT SEQUENCE SINGLE
- +2 ; INPUT: REQT = Request Type: SDEC CONTACT, REQUEST/CONSULTATION or SDEC APPT REQUEST
- +3 ; RIEN = IEN of the record of interest
- +4 ; OUTPUT:
- +5 ; RTU = Newly created contact sequence number
- +6 IF $GET(RTU)=""
- SET RTU=0
- +7 if REQT=""!("^R^A^RTC^C^P^V^"'[("^"_REQT_"^"))
- QUIT
- +8 if RIEN=""
- QUIT
- +9 ;
- +10 ; $O backwards to get the last entry entered if there are more than one entry in the x-ref
- +11 SET CC=$ORDER(^SDEC(409.86,"SRP",RIEN,""),-1)
- +12 IF CC<1
- DO EXIT
- QUIT
- +13 SET RCD=$GET(^SDEC(409.86,CC,0))
- if RCD=""
- QUIT
- +14 SET SQU=""
- SET SQU=$PIECE($GET(^SDEC(409.86,CC,1,0)),"^",3)
- +15 if $GET(SQU)=""
- QUIT
- +16 if REQT'=$PIECE($GET(RCD),"^",4)
- QUIT
- +17 SET RE1=SQU+1
- +18 SET $PIECE(^SDEC(409.86,CC,0),"^",5)=RE1
- +19 QUIT
- +20 ;
- UPDATE(RTT,IEN,CONDT,CTYPE,COMM,DTEN) ;
- +1 ; RPC: SDEC CONTACT UPDATE
- +2 if '$GET(IEN)
- QUIT
- +3 if '$GET(CONDT)
- QUIT
- +4 if '$DATA(CTYPE)
- QUIT
- +5 IF '$DATA(COMM)
- SET COMM=""
- +6 IF '$GET(DTEN)
- SET DTEN=""
- +7 ;
- +8 SET (MULT,RTT,CC,CCC,COUNT,MULTN)=""
- +9 ;
- +10 SET MULT=""
- SET MULT=$GET(^SDEC(409.86,IEN,1,0))
- IF MULT'=""
- Begin DoDot:1
- +11 SET MULTN=$PIECE(MULT,"^",4)
- IF MULTN'=""
- Begin DoDot:2
- +12 SET COUNT=MULTN
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 IF COUNT'=""
- SET COUNT=COUNT+1
- Begin DoDot:1
- +15 SET ^SDEC(409.86,IEN,1,0)="^409.863D^"_COUNT_"^"_COUNT
- +16 SET ^SDEC(409.86,IEN,1,COUNT,0)=CONDT
- +17 SET ^SDEC(409.86,IEN,1,COUNT,1)=CTYPE_"^"_COMM_"^"_0_"^"_COUNT_"^"_DUZ_"^"_DTEN
- +18 SET ^SDEC(409.86,IEN,1,"B",CONDT,COUNT)=""
- +19 ; 3/6/18 WTC/ZEB create date/user cross-reference.
- SET ^SDEC(409.86,"AD",DTEN,DUZ,IEN,COUNT)=""
- +20 QUIT
- End DoDot:1
- +21 DO EXIT
- +22 QUIT
- GETSTC(RET,CLIEN) ;
- +1 ; RPC: SDEC CONTACT STOP CODE
- +2 if CLIEN=""
- QUIT
- +3 ;
- +4 ;CLIEN=Clinic IEN
- +5 ;HLF0=Hospital Location File 0 node
- +6 ;SNUM=Stopc Code IEN [0,7]
- +7 ;STPC=Stop Code 40.7
- +8 ;CSNUM=Credit Stop IEN [0,18]
- +9 ;CSTPC=Credit Stop Code 40.7
- +10 ;
- +11 SET (HLF0,SNUM,STPC,CSNUM,CSTPC,CNUM)=""
- +12 ;
- +13 SET HLF0=$GET(^SC(CLIEN,0))
- IF HLF0'=""
- Begin DoDot:1
- +14 SET SNUM=$PIECE($GET(HLF0),"^",7)
- IF SNUM'=""
- Begin DoDot:2
- +15 SET STPC=$$GET1^DIQ(40.7,SNUM,1)
- End DoDot:2
- +16 SET CNUM=$PIECE($GET(HLF0),"^",18)
- IF CNUM'=""
- Begin DoDot:2
- +17 SET CSTPC=$$GET1^DIQ(40.7,CNUM,1)
- End DoDot:2
- End DoDot:1
- +18 SET RET=STPC_"^"_CSTPC
- +19 KILL HLF0,SNUM,STPC,CSNUM,CSTPC,CNUM
- +20 QUIT
- EXIT ;
- +1 KILL MULT,CC,CCC,COUNT,COMM,DTEN,ENDT,AR40985,RECALL,ROOT,GMR
- +2 KILL JJ,JJ1,RCD,SQU,DF2,DFN2,CC1,CC2,RCD,SQU,ENTU,ENTUN
- +3 KILL REC,REC1,REC2,ENDT,MULTN,CLN,PDT,REQT,SER,RIEN,SDRIEN
- +4 QUIT