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

SDECCON.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;This API provides SDEC CONTACT(#409.86)file information to the VSE VS GUI.
  1. ; 3/6/18 - wtc/zeb Added new cross-reference for audit statistics compiler. Patch 686
  1. ;
  1. Q
  1. DISPLAY(RTU,DFN,CLN,PDT,REQT,SER) ;
  1. ; RPC: SDEC CONTACT DISPLAY
  1. Q:'$G(DFN)
  1. Q:'$G(PDT)
  1. Q:'$D(REQT)
  1. S (CC,CC1,CC2,REC)=""
  1. ;
  1. S PDT=$$NETTOFM^SDECDATE(PDT,"N","N") ;CONVERT TO FILEMAN DATE
  1. ;
  1. S CC="" F S CC=$O(^SDEC(409.86,"B",DFN,CC)) Q:CC="" D
  1. .S REC="" S REC=^SDEC(409.86,CC,0)
  1. .Q:PDT'=$P($G(REC),"^",3)
  1. .I $G(CLN)'="" Q:$G(CLN)'=$P($G(REC),"^",2)
  1. .I $G(SER)'="" Q:$G(SER)'=$P($G(REC),"^",6)
  1. .Q:REQT'=$P($G(REC),"^",4)
  1. .S RTU=CC_"^"_REC
  1. .Q
  1. D EXIT
  1. Q
  1. ;
  1. DISPLAY1(RTU,REQT,RIEN) ;
  1. ; RPC: SDEC CONTACT DISPLAY SINGLE
  1. ; INPUT: REQT = Request Type: SDEC CONTACT, REQUEST/CONSULTATION or SDEC APPT REQUEST
  1. ; RIEN = IEN of the record of interest
  1. ; OUTPUT:
  1. ; 1st ^ Piece = IEN of VistA record identified
  1. ; 2nd ^ Piece = 0 node of File #409.86 for the identified record
  1. ;
  1. I $G(RTU)="" S RTU=0
  1. Q:REQT=""!("^R^A^RTC^C^P^V^"'[("^"_REQT_"^"))
  1. Q:RIEN=""
  1. ;
  1. S (CC,ROOT,REC,GMR,AR40985,RECALL)=""
  1. ; $O backwards to get the last entry entered if there are more than one entry in the x-ref
  1. S CC=$O(^SDEC(409.86,"SRP",RIEN,""),-1)
  1. I CC<1 D EXIT Q
  1. S ROOT="" S ROOT=$P(^SDEC(409.86,CC,0),"^",7)
  1. Q:$P(ROOT,";",1)'=RIEN
  1. ; Load 0 node for return
  1. S REC="" S REC=^SDEC(409.86,CC,0)
  1. ; Check for SDEC CONTACT
  1. I REQT="R" D
  1. .S RECALL="" S RECALL=$G(^SD(403.5,RIEN,0))
  1. .Q:RECALL=""
  1. .Q:$P(REC,"^",1)'=$P(RECALL,"^",1)
  1. .S RTU=CC_"^"_REC
  1. .Q
  1. ; Check for SDEC APPT REQUEST
  1. I (REQT="A")!(REQT="RTC")!(REQT="V") D
  1. .S AR40985="" S AR40985=$G(^SDEC(409.85,RIEN,0))
  1. .Q:AR40985=""
  1. .Q:$P(REC,"^",1)'=$P(AR40985,"^",1)
  1. .S RTU=CC_"^"_REC
  1. .Q
  1. ; Check for REQUEST/CONSULTATION
  1. I REQT="C"!(REQT="P") D
  1. .S GMR="" S GMR=$G(^GMR(123,RIEN,0))
  1. .Q:GMR=""
  1. .Q:$P(REC,"^",1)'=$P(GMR,"^",2)
  1. .Q:$P($G(REC),"^",1)'=$P($G(GMR),"^",2)
  1. .S RTU=CC_"^"_REC
  1. .Q
  1. D EXIT
  1. Q
  1. ;
  1. DISMULT(RTT,CIEN) ;
  1. ; RPC: SDEC CONTACT MULTI-DISPLAY
  1. Q:'$G(CIEN)
  1. ;
  1. S (CC1,CC2,REC1,REC2,RTT,ENDT)=""
  1. ;
  1. S CC2="" F S CC2=$O(^SDEC(409.86,CIEN,1,CC2)) Q:CC2="" D
  1. .S REC2="" S REC2=$G(^SDEC(409.86,CIEN,1,CC2,1)) Q:REC2="" D
  1. ..S ENDT="" S ENDT=$P($G(^SDEC(409.86,CIEN,1,CC2,0)),"^",1)
  1. ..S (ENTU,ENTUN)="" S ENTUN=$P(REC2,"^",5) I ENTUN>0 D
  1. ...S ENTU=$$GET1^DIQ(200,ENTUN,.01,"E")
  1. ..S RTT=RTT_CC1_"^"_REC2_"^"_ENTU_"^"_ENDT_";"
  1. ..Q
  1. D EXIT
  1. Q
  1. ;
  1. NEW(RET,DFN,CLI,DTP,REQT,SRV,DTCON,CONT,COM,DTENT,RIEN) ;
  1. ; RPC: SDEC CONTACT NEW
  1. S RET=0
  1. Q:'$G(DFN)
  1. Q:'$G(DTP)
  1. Q:'$D(REQT)
  1. Q:'$G(DTCON)
  1. Q:'$D(CONT)
  1. Q:'$G(DTENT)
  1. Q:'$G(RIEN)
  1. I '$D(COM) S COM=""
  1. I '$G(CLI) S CLI=""
  1. I '$G(SRV) S SRV=""
  1. S DTP=$$NETTOFM^SDECDATE(DTP,"N","N") ;CONVERT TO FILEMAN DATE
  1. ;
  1. ; Determine variable pointer file
  1. S SDRIEN=""
  1. I RIEN>0 D
  1. . I (REQT="A")!(REQT="RTC")!(REQT="V") D
  1. . . Q:$P($G(^SDEC(409.85,RIEN,0)),U,1)'=DFN
  1. . . 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")
  1. . . S SDRIEN=RIEN_";"_"SDEC(409.85," Q
  1. . Q:SDRIEN'=""
  1. . I REQT="C"!(REQT="P") D
  1. . . Q:$P($G(^GMR(123,RIEN,0)),U,2)'=DFN
  1. . . Q:$P($G(^GMR(123,RIEN,0)),U,17)'=REQT
  1. . . Q:CLI'=""&(CLI'=$P(^GMR(123,RIEN,0),U,4))
  1. . . S SDRIEN=RIEN_";"_"GMR(123," Q
  1. . Q:SDRIEN'=""
  1. . I REQT="R" D
  1. . . Q:$P($G(^SD(403.5,RIEN,0)),U,1)'=DFN
  1. . . Q:$P($G(^SD(403.5,RIEN,0)),U,2)'=CLI
  1. . . S SDRIEN=RIEN_";"_"SD(403.5,"
  1. . Q
  1. ;
  1. S (DFN2,CC1,CC2)=""
  1. ;
  1. S DFN2="" F S DFN2=$O(^SDEC(409.86,"B",DFN2)) Q:DFN2="" D
  1. .S CC1="" F S CC1=$O(^SDEC(409.86,"B",DFN2,CC1)) Q:CC1="" D
  1. ..S CC2=CC2+1
  1. ..Q
  1. S CC2=CC2+1 D
  1. .S ^SDEC(409.86,0)="SDEC CONTACT^409.86P^"_CC2_"^"_CC2
  1. .S ^SDEC(409.86,CC2,0)=DFN_"^"_CLI_"^"_DTP_"^"_REQT_"^"_1_"^"_SRV
  1. .S ^SDEC(409.86,CC2,1,0)="^409.863D^1^1"
  1. .S ^SDEC(409.86,CC2,1,1,0)=DTCON
  1. .S ^SDEC(409.86,CC2,1,1,1)=CONT_"^"_COM_"^"_0_"^"_1_"^"_DUZ_"^"_DTENT
  1. .S ^SDEC(409.86,"B",DFN,CC2)=""
  1. .S ^SDEC(409.86,CC2,1,"B",DTCON,1)=""
  1. .S ^SDEC(409.86,"AD",DTENT,DUZ,CC2,1)="" ; 3/6/18 WTC/ZEB create date/user cross-reference.
  1. .I SDRIEN'="" S $P(^SDEC(409.86,CC2,0),U,7)=SDRIEN ; APPT REQUEST TYPE (#2.3)
  1. .; Build the SRP x-ref
  1. .N DIK,DA
  1. .S DIK="^SDEC(409.86,",DA=CC2,DIK(1)=2.3
  1. .D EN1^DIK
  1. .Q
  1. S RET=1
  1. D EXIT
  1. Q
  1. SEQ(RE1,DF1,CL1,PDATE,RTYPE,SRR) ;
  1. ; RPC: SDEC CONTACT SEQUENCE
  1. Q:'$G(DF1)
  1. Q:'$G(PDATE)
  1. I '$G(CL1) S CL1=""
  1. I '$G(SRR) S SRR=""
  1. ;
  1. S (JJ,JJ1,RCD,SQU,DF2)=""
  1. S PDATE=$$NETTOFM^SDECDATE(PDATE,"N","N")
  1. ;
  1. S JJ="" F S JJ=$O(^SDEC(409.86,"B",DF1,JJ)) Q:JJ="" D
  1. .S RCD="" S RCD=$G(^SDEC(409.86,JJ,0)) Q:RCD="" D
  1. ..S SQU="" S SQU=$P($G(^SDEC(409.86,JJ,1,0)),"^",3) D
  1. ...Q:$G(SQU)=""
  1. ...Q:PDATE'=$P($G(RCD),"^",3)
  1. ...Q:RTYPE'=$P($G(RCD),"^",4)
  1. ...I $P($G(RCD),"^",2)=CL1 D
  1. ....S $P(^SDEC(409.86,JJ,0),"^",5)=SQU+1
  1. ....S RE1=SQU+1
  1. ....Q
  1. ...I $P($G(RCD),"^",6)=SRR D
  1. ....S $P(^SDEC(409.86,JJ,0),"^",5)=SQU+1
  1. ....S RE1=SQU+1
  1. ....Q
  1. D EXIT
  1. Q
  1. ;
  1. SEQ1(RTU,REQT,RIEN) ;
  1. ; RPC: SDEC CONTACT SEQUENCE SINGLE
  1. ; INPUT: REQT = Request Type: SDEC CONTACT, REQUEST/CONSULTATION or SDEC APPT REQUEST
  1. ; RIEN = IEN of the record of interest
  1. ; OUTPUT:
  1. ; RTU = Newly created contact sequence number
  1. I $G(RTU)="" S RTU=0
  1. Q:REQT=""!("^R^A^RTC^C^P^V^"'[("^"_REQT_"^"))
  1. Q:RIEN=""
  1. ;
  1. ; $O backwards to get the last entry entered if there are more than one entry in the x-ref
  1. S CC=$O(^SDEC(409.86,"SRP",RIEN,""),-1)
  1. I CC<1 D EXIT Q
  1. S RCD=$G(^SDEC(409.86,CC,0)) Q:RCD=""
  1. S SQU="" S SQU=$P($G(^SDEC(409.86,CC,1,0)),"^",3)
  1. Q:$G(SQU)=""
  1. Q:REQT'=$P($G(RCD),"^",4)
  1. S RE1=SQU+1
  1. S $P(^SDEC(409.86,CC,0),"^",5)=RE1
  1. Q
  1. ;
  1. UPDATE(RTT,IEN,CONDT,CTYPE,COMM,DTEN) ;
  1. ; RPC: SDEC CONTACT UPDATE
  1. Q:'$G(IEN)
  1. Q:'$G(CONDT)
  1. Q:'$D(CTYPE)
  1. I '$D(COMM) S COMM=""
  1. I '$G(DTEN) S DTEN=""
  1. ;
  1. S (MULT,RTT,CC,CCC,COUNT,MULTN)=""
  1. ;
  1. S MULT="" S MULT=$G(^SDEC(409.86,IEN,1,0)) I MULT'="" D
  1. .S MULTN=$P(MULT,"^",4) I MULTN'="" D
  1. ..S COUNT=MULTN
  1. .Q
  1. I COUNT'="" S COUNT=COUNT+1 D
  1. .S ^SDEC(409.86,IEN,1,0)="^409.863D^"_COUNT_"^"_COUNT
  1. .S ^SDEC(409.86,IEN,1,COUNT,0)=CONDT
  1. .S ^SDEC(409.86,IEN,1,COUNT,1)=CTYPE_"^"_COMM_"^"_0_"^"_COUNT_"^"_DUZ_"^"_DTEN
  1. .S ^SDEC(409.86,IEN,1,"B",CONDT,COUNT)=""
  1. .S ^SDEC(409.86,"AD",DTEN,DUZ,IEN,COUNT)="" ; 3/6/18 WTC/ZEB create date/user cross-reference.
  1. .Q
  1. D EXIT
  1. Q
  1. GETSTC(RET,CLIEN) ;
  1. ; RPC: SDEC CONTACT STOP CODE
  1. Q:CLIEN=""
  1. ;
  1. ;CLIEN=Clinic IEN
  1. ;HLF0=Hospital Location File 0 node
  1. ;SNUM=Stopc Code IEN [0,7]
  1. ;STPC=Stop Code 40.7
  1. ;CSNUM=Credit Stop IEN [0,18]
  1. ;CSTPC=Credit Stop Code 40.7
  1. ;
  1. S (HLF0,SNUM,STPC,CSNUM,CSTPC,CNUM)=""
  1. ;
  1. S HLF0=$G(^SC(CLIEN,0)) I HLF0'="" D
  1. .S SNUM=$P($G(HLF0),"^",7) I SNUM'="" D
  1. ..S STPC=$$GET1^DIQ(40.7,SNUM,1)
  1. .S CNUM=$P($G(HLF0),"^",18) I CNUM'="" D
  1. ..S CSTPC=$$GET1^DIQ(40.7,CNUM,1)
  1. S RET=STPC_"^"_CSTPC
  1. K HLF0,SNUM,STPC,CSNUM,CSTPC,CNUM
  1. Q
  1. EXIT ;
  1. K MULT,CC,CCC,COUNT,COMM,DTEN,ENDT,AR40985,RECALL,ROOT,GMR
  1. K JJ,JJ1,RCD,SQU,DF2,DFN2,CC1,CC2,RCD,SQU,ENTU,ENTUN
  1. K REC,REC1,REC2,ENDT,MULTN,CLN,PDT,REQT,SER,RIEN,SDRIEN
  1. Q