- SCAPMCU1 ;ALB/REW - TEAM API UTILITIES ; 7/12/99 9:33am ;07/06/2017
- ;;5.3;Scheduling;**41,45,48,177,666**;AUG 13, 1993;Build 4
- ;;1.0
- INIT(SCOK) ; setup date array & error arrays if none passed in
- ; VARIABLES SET:
- ; SCOK - SET TO 0 IF ERROR
- ;
- ; Makes sure the following are defined:
- ; scbegin,scend,scincl,@scdates('begin'),@scdates@('end'),@scdates@('incl') - defaults are today & inclusive
- ;
- ; Note: you should NEW the above just before making this call
- ; ---
- N SCNOW ;666
- S (SCN,SCESEQ,SCLSEQ)=0
- IF '$L($G(SCERR)) K ^TMP("SCERR",$J) S SCERR="^TMP(""SCERR"",$J)"
- IF '$L($G(SCLIST)) S SCLIST="^TMP(""SC TMP LIST"",$J)" K ^TMP("SC TMP LIST",$J)
- IF (SCERR="SCERR")!(SCERR="SCLIST")!((SCERR'?1A1.7AN)&(SCERR'?1"^"1A.20E)) D S SCOK=0
- . S SCPARM("ERROR ARRAY")=$G(SCERR,"Undefined")
- . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- IF SCLIST="SCERR"!(SCLIST="SCLIST")!((SCLIST'?1A1.7AN.1"(".60E)&(SCLIST'?1"^"1A1.7AN.1"(".60E)) S SCOK=0 D S SCOK=0
- . S SCPARM("OUTPUT ARRAY")=$G(SCLIST,"Undefined")
- . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- S:'$D(SCDATES)!($G(SCDATES)="") SCDATES="SCDTS"
- S SCNOW=$$NOW^XLFDT ;666
- S SCBEGIN=$G(@SCDATES@("BEGIN"),SCNOW),SCBEGIN=$S(SCBEGIN:SCBEGIN,1:SCNOW) ;666
- S SCEND=$G(@SCDATES@("END"),SCNOW),SCEND=$S(SCEND:SCEND,1:SCNOW) ;666
- S SCINCL=$G(@SCDATES@("INCL"),1)
- S (SCN,SCESEQ,SCLSEQ)=0
- S:'$D(@SCDATES@("BEGIN")) @SCDATES@("BEGIN")=SCBEGIN
- S:'$D(@SCDATES@("END")) @SCDATES@("END")=SCEND
- S:'$D(@SCDATES@("INCL")) @SCDATES@("INCL")=SCINCL
- Q
- ;
- ; bp/cmf 177 - added SCFUTURE input param, used at PCPOSCNT+17
- ;;bp/cmf 177; orig entry call; PCPOSCNT(SCTP,SCDATE,SCPCONLY);this is a more efficient count of PC patients assigned to position
- PCPOSCNT(SCTP,SCDATE,SCPCONLY,SCFUTURE) ;this is a more efficient count of PC patients assigned to position
- ; Input: SCTP - ien to 404.57
- ; SCDATE - date of concern, default=DT
- ; SCPCONLY - 1= must be pc, 0=all assignments 1=DEFAULT
- ; SCFUTURE - 1= include future, 0=current 0=DEFAULT ;;bp/cmf 177
- ;returns count of patient assignments or -1 if error
- N SCPTPA,SCCNT,SCHSTIEN,SCNODE
- Q:'$G(SCTP) -1
- S SCDATE=$G(SCDATE,DT)
- S:'$L($G(SCPCONLY)) SCPCONLY=1
- S:'$L($G(SCFUTURE)) SCFUTURE=0 ;;bp/cmf 177 add
- S (SCPTPA,SCCNT)=0
- F S SCPTPA=$O(^SCPT(404.43,"APTPA",SCTP,SCPTPA)) Q:'SCPTPA D
- .S SCHSTIEN=0
- .F S SCHSTIEN=$O(^SCPT(404.43,"APTPA",SCTP,SCPTPA,SCHSTIEN)) Q:'SCHSTIEN D
- ..S SCNODE=$G(^SCPT(404.43,SCHSTIEN,0))
- ..Q:$P(SCNODE,U,4)&($P(SCNODE,U,4)<SCDATE)
- ..;;bp/cmf 177;orig code;;Q:$P(SCNODE,U,3)>SCDATE
- ..Q:('SCFUTURE)&($P(SCNODE,U,3)>SCDATE) ;;bp/cmf 177 mod-use scfuture
- ..Q:SCPCONLY&('$P(SCNODE,U,5)) ;pc role is not 1 or 2
- ..S SCCNT=SCCNT+1
- Q SCCNT
- ;
- TEAMCNT(SCTM,DATE) ;this is a more efficient version of the count
- N DFN,SCCNT,SCNODE,HISTIEN
- Q:'$G(SCTM) 0
- S DATE=$G(DATE,DT)
- S (DFN,SCCNT)=0
- F S DFN=$O(^SCPT(404.42,"ATMPT",SCTM,DFN)) Q:'DFN D
- .S HISTIEN=0
- .F S HISTIEN=$O(^SCPT(404.42,"ATMPT",SCTM,DFN,HISTIEN)) Q:'HISTIEN D
- ..S SCNODE=$G(^SCPT(404.42,HISTIEN,0))
- ..Q:$P(SCNODE,U,9)&($P(SCNODE,U,9)<DATE)
- ..Q:$P(SCNODE,U,2)>DATE
- ..S SCCNT=SCCNT+1
- Q SCCNT
- ;
- TEAMCNT2(SCTM,DATE) ;this is the count of patients assigned to the team on a date
- ; Input: SCTM - ien to 404.51
- ; DATE - date of concern, default=DT
- N SCX,SCDATES,SCTEAMS,SCERR,X
- S SCDATES("BEGIN")=$G(DATE,DT)
- S SCDATES("END")=SCDATES("BEGIN")
- S SCX=$$PTTM^SCAPMC(SCTM,"SCDATES","^TMP(""SCTEAMS"",$J,""CNT"")","SCERRX")
- IF 'SCX S X=-SCX
- ELSE D
- .S DFN=0
- .F X=0:1 S DFN=$O(^TMP("SCTEAMS",$J,"CNT","SCPTA",DFN)) Q:'DFN
- K ^TMP("SCTEAMS",$J,"CNT")
- Q X
- ACTHISTB(FILE,IEN) ;boolean active function
- ;MOVED TO SCAPMCU2
- Q $$ACTHISTB^SCAPMCU2(.FILE,.IEN)
- ACTHIST(FILE,IEN,SCDATES,SCERR) ;is entry active for a time period?
- ;MOVED TO SCAPMCU2
- Q $$ACTHIST^SCAPMCU2(.FILE,.IEN,.SCDATES,.SCERR)
- ;
- LASTDATE(FILE,IEN) ;gets last date for team or position from 404.52,404.58,404.59 - uses DATES function below
- ; Input Parameters:
- ; File = either 404.52 or 404.58 or 404.59
- ; IEN = pointer to team(404.51) or team position(404.57)
- ; Returned:
- ; -1 if error,o/w latest date defined 0=no historical dates
- N SCX
- S SCX=$$DATES(.FILE,.IEN,3990101) ; gets dates as of 1/1/2999
- Q $S($P(SCX,U,1)<0:-1,$P(SCX,U,3):$P(SCX,U,3),1:+$P(SCX,U,2))
- ;
- DATES(FILE,IEN,DATE) ;used to return latest activation & inactivation date
- ; Input Parameters:
- ; File = either 404.52, 404.53, 404.58, or 404.59
- ; IEN = pointer to team(404.51) or team position(404.57)
- ; DATE = default=DT
- ; Returned:
- ; status^actdate^inactdate^scien^first actdate? [1=yes/null=no]
- ST N ROOT,EFFDT,STATUS,ACTDT,INACTDT,X,FUTURE,PREVDT,SCTODAY,PREVST,SCSTAT,SCIEN,SCLAST
- S:'$G(DATE) DATE=DT
- S STATUS=-1,SCTODAY=0
- S SCSTAT=1
- ;bp/cmf - 177 change begin
- G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
- ;orig;G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
- ;bp/cmf - 177 change begin
- S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
- S EFFDT=-DATE
- S X=ROOT_")"
- ;if there is an active x-ref
- IF $D(@X) D
- .;if today is an activation date
- .IF $D(@X@(EFFDT)) S ACTDT=-EFFDT
- .;if today is not an activation date get previous one
- .ELSE D
- ..S ACTDT=-$O(@X@(EFFDT))
- .;if no activation in past get one in future
- .S:'$G(ACTDT) ACTDT=-$O(@X@(EFFDT),-1),FUTURE=1
- .S SCSTAT=0
- .S INACTDT=$O(@X@(-(ACTDT-.000001)),-1),INACTDT=$S(INACTDT:-INACTDT,1:INACTDT)
- .S STATUS=$$DTCHK^SCAPU1(DATE,DATE,0,ACTDT,INACTDT)
- .S SCSTAT=STATUS
- .S X=ROOT_","_$S(SCSTAT:-ACTDT,1:-INACTDT)_")"
- .S SCIEN=$O(@X@(0))
- ELSE D
- .S STATUS=0
- QTDATES Q STATUS_U_$G(ACTDT)_U_$G(INACTDT)_U_$G(SCIEN)_U_$G(FUTURE)
- ;
- ERR(SEQ,ERNUM,PARMS,OUTPUT,SCER) ;-- process errors
- ;if no dialog entry 4040000 will be processed
- S ERNUM=$G(ERNUM,4040000)
- S:'$$GET1^DIQ(.84,$G(ERNUM)_",",.01) ERNUM=4040000
- IF SCER]"" D
- . S SEQ=$G(SEQ,0)+1
- . S SCER(SEQ)=ERNUM
- . ;S @SCER@(0)=$G(@SCER@(0))+1 ;bp/djb 7/12/99
- . S SCER(0)=$G(SCER(0))+1
- . ;D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,.SCER) ;bp/djb 7/12/99
- . D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,"SCER")
- Q
- ;
- OKTMPOS(TEAM,POSITION,DATE) ;validate legitimate position in a team for a dt
- ; used in screen for pc practitioner position of patient team assngt
- ;
- ; TEAM - ien of team file
- ; POSITION - ien of team position file
- ; DATE - date of interest
- ; return 1 if ok, 0 ow
- ;
- CHK ;
- N SCTP,SCOK,SCPOS0
- S SCOK=0
- S:'$L($G(SCERR)) SCERR="^TMP(""SCERR"",$J)"
- IF '$D(^SCTM(404.51,+$G(TEAM),0)) D G QTOKTP
- . S SCPARM("TEAM")=$G(TEAM,"Undefined")
- . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- IF '$D(^SCTM(404.57,+$G(POSITION),0)) D G QTOKTP
- . S SCPARM("POSITION")=$G(POSITION,"Undefined")
- . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- IF '$G(DATE) D G QTOKTP
- . S SCPARM("DATE")=$G(DATE,"Undefined")
- . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- S SCPOS0=$G(^SCTM(404.57,POSITION,0))
- ;if position not linked to team
- G QTOKTP:$P(SCPOS0,U,2)'=TEAM
- ;if not active position
- G QTOKTP:'$$DATES(404.59,POSITION,DATE)
- S SCOK=1
- QTOKTP Q SCOK
- RSNDICS(EVCODE) ; -- called by input transform and screen logic for type of reason
- ; Input: EVCODE = event code (e.g. ZM1)
- ; Used to check for fields that point to Scheduling Reason File
- ; Piece = Piece number of zero node of
- Q $P(^SD(403.43,$P(^(0),U,2),0),U,1)=EVCODE
- ;
- OKPREC(TEAM) ; - called by screen logic for preceptor position file (#.1) of team position (#404.57) file
- ; Input; TEAM = Pointer to team file (#404.51) for team position with preceptor
- ; requires position being assigned to be a possible preceptor position
- ; AND that position is from the same team as the supervised position
- Q ($P(^SCTM(404.57,Y,0),U,12))&($P(^SCTM(404.57,Y,0),U,2)=TEAM)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMCU1 7951 printed Jan 18, 2025@03:39:27 Page 2
- SCAPMCU1 ;ALB/REW - TEAM API UTILITIES ; 7/12/99 9:33am ;07/06/2017
- +1 ;;5.3;Scheduling;**41,45,48,177,666**;AUG 13, 1993;Build 4
- +2 ;;1.0
- INIT(SCOK) ; setup date array & error arrays if none passed in
- +1 ; VARIABLES SET:
- +2 ; SCOK - SET TO 0 IF ERROR
- +3 ;
- +4 ; Makes sure the following are defined:
- +5 ; scbegin,scend,scincl,@scdates('begin'),@scdates@('end'),@scdates@('incl') - defaults are today & inclusive
- +6 ;
- +7 ; Note: you should NEW the above just before making this call
- +8 ; ---
- +9 ;666
- NEW SCNOW
- +10 SET (SCN,SCESEQ,SCLSEQ)=0
- +11 IF '$LENGTH($GET(SCERR))
- KILL ^TMP("SCERR",$JOB)
- SET SCERR="^TMP(""SCERR"",$J)"
- +12 IF '$LENGTH($GET(SCLIST))
- SET SCLIST="^TMP(""SC TMP LIST"",$J)"
- KILL ^TMP("SC TMP LIST",$JOB)
- +13 IF (SCERR="SCERR")!(SCERR="SCLIST")!((SCERR'?1A1.7AN)&(SCERR'?1"^"1A.20E))
- Begin DoDot:1
- +14 SET SCPARM("ERROR ARRAY")=$GET(SCERR,"Undefined")
- +15 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- End DoDot:1
- SET SCOK=0
- +16 IF SCLIST="SCERR"!(SCLIST="SCLIST")!((SCLIST'?1A1.7AN.1"(".60E)&(SCLIST'?1"^"1A1.7AN.1"(".60E))
- SET SCOK=0
- Begin DoDot:1
- +17 SET SCPARM("OUTPUT ARRAY")=$GET(SCLIST,"Undefined")
- +18 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- End DoDot:1
- SET SCOK=0
- +19 if '$DATA(SCDATES)!($GET(SCDATES)="")
- SET SCDATES="SCDTS"
- +20 ;666
- SET SCNOW=$$NOW^XLFDT
- +21 ;666
- SET SCBEGIN=$GET(@SCDATES@("BEGIN"),SCNOW)
- SET SCBEGIN=$SELECT(SCBEGIN:SCBEGIN,1:SCNOW)
- +22 ;666
- SET SCEND=$GET(@SCDATES@("END"),SCNOW)
- SET SCEND=$SELECT(SCEND:SCEND,1:SCNOW)
- +23 SET SCINCL=$GET(@SCDATES@("INCL"),1)
- +24 SET (SCN,SCESEQ,SCLSEQ)=0
- +25 if '$DATA(@SCDATES@("BEGIN"))
- SET @SCDATES@("BEGIN")=SCBEGIN
- +26 if '$DATA(@SCDATES@("END"))
- SET @SCDATES@("END")=SCEND
- +27 if '$DATA(@SCDATES@("INCL"))
- SET @SCDATES@("INCL")=SCINCL
- +28 QUIT
- +29 ;
- +30 ; bp/cmf 177 - added SCFUTURE input param, used at PCPOSCNT+17
- +31 ;;bp/cmf 177; orig entry call; PCPOSCNT(SCTP,SCDATE,SCPCONLY);this is a more efficient count of PC patients assigned to position
- PCPOSCNT(SCTP,SCDATE,SCPCONLY,SCFUTURE) ;this is a more efficient count of PC patients assigned to position
- +1 ; Input: SCTP - ien to 404.57
- +2 ; SCDATE - date of concern, default=DT
- +3 ; SCPCONLY - 1= must be pc, 0=all assignments 1=DEFAULT
- +4 ; SCFUTURE - 1= include future, 0=current 0=DEFAULT ;;bp/cmf 177
- +5 ;returns count of patient assignments or -1 if error
- +6 NEW SCPTPA,SCCNT,SCHSTIEN,SCNODE
- +7 if '$GET(SCTP)
- QUIT -1
- +8 SET SCDATE=$GET(SCDATE,DT)
- +9 if '$LENGTH($GET(SCPCONLY))
- SET SCPCONLY=1
- +10 ;;bp/cmf 177 add
- if '$LENGTH($GET(SCFUTURE))
- SET SCFUTURE=0
- +11 SET (SCPTPA,SCCNT)=0
- +12 FOR
- SET SCPTPA=$ORDER(^SCPT(404.43,"APTPA",SCTP,SCPTPA))
- if 'SCPTPA
- QUIT
- Begin DoDot:1
- +13 SET SCHSTIEN=0
- +14 FOR
- SET SCHSTIEN=$ORDER(^SCPT(404.43,"APTPA",SCTP,SCPTPA,SCHSTIEN))
- if 'SCHSTIEN
- QUIT
- Begin DoDot:2
- +15 SET SCNODE=$GET(^SCPT(404.43,SCHSTIEN,0))
- +16 if $PIECE(SCNODE,U,4)&($PIECE(SCNODE,U,4)<SCDATE)
- QUIT
- +17 ;;bp/cmf 177;orig code;;Q:$P(SCNODE,U,3)>SCDATE
- +18 ;;bp/cmf 177 mod-use scfuture
- if ('SCFUTURE)&($PIECE(SCNODE,U,3)>SCDATE)
- QUIT
- +19 ;pc role is not 1 or 2
- if SCPCONLY&('$PIECE(SCNODE,U,5))
- QUIT
- +20 SET SCCNT=SCCNT+1
- End DoDot:2
- End DoDot:1
- +21 QUIT SCCNT
- +22 ;
- TEAMCNT(SCTM,DATE) ;this is a more efficient version of the count
- +1 NEW DFN,SCCNT,SCNODE,HISTIEN
- +2 if '$GET(SCTM)
- QUIT 0
- +3 SET DATE=$GET(DATE,DT)
- +4 SET (DFN,SCCNT)=0
- +5 FOR
- SET DFN=$ORDER(^SCPT(404.42,"ATMPT",SCTM,DFN))
- if 'DFN
- QUIT
- Begin DoDot:1
- +6 SET HISTIEN=0
- +7 FOR
- SET HISTIEN=$ORDER(^SCPT(404.42,"ATMPT",SCTM,DFN,HISTIEN))
- if 'HISTIEN
- QUIT
- Begin DoDot:2
- +8 SET SCNODE=$GET(^SCPT(404.42,HISTIEN,0))
- +9 if $PIECE(SCNODE,U,9)&($PIECE(SCNODE,U,9)<DATE)
- QUIT
- +10 if $PIECE(SCNODE,U,2)>DATE
- QUIT
- +11 SET SCCNT=SCCNT+1
- End DoDot:2
- End DoDot:1
- +12 QUIT SCCNT
- +13 ;
- TEAMCNT2(SCTM,DATE) ;this is the count of patients assigned to the team on a date
- +1 ; Input: SCTM - ien to 404.51
- +2 ; DATE - date of concern, default=DT
- +3 NEW SCX,SCDATES,SCTEAMS,SCERR,X
- +4 SET SCDATES("BEGIN")=$GET(DATE,DT)
- +5 SET SCDATES("END")=SCDATES("BEGIN")
- +6 SET SCX=$$PTTM^SCAPMC(SCTM,"SCDATES","^TMP(""SCTEAMS"",$J,""CNT"")","SCERRX")
- +7 IF 'SCX
- SET X=-SCX
- +8 IF '$TEST
- Begin DoDot:1
- +9 SET DFN=0
- +10 FOR X=0:1
- SET DFN=$ORDER(^TMP("SCTEAMS",$JOB,"CNT","SCPTA",DFN))
- if 'DFN
- QUIT
- End DoDot:1
- +11 KILL ^TMP("SCTEAMS",$JOB,"CNT")
- +12 QUIT X
- ACTHISTB(FILE,IEN) ;boolean active function
- +1 ;MOVED TO SCAPMCU2
- +2 QUIT $$ACTHISTB^SCAPMCU2(.FILE,.IEN)
- ACTHIST(FILE,IEN,SCDATES,SCERR) ;is entry active for a time period?
- +1 ;MOVED TO SCAPMCU2
- +2 QUIT $$ACTHIST^SCAPMCU2(.FILE,.IEN,.SCDATES,.SCERR)
- +3 ;
- LASTDATE(FILE,IEN) ;gets last date for team or position from 404.52,404.58,404.59 - uses DATES function below
- +1 ; Input Parameters:
- +2 ; File = either 404.52 or 404.58 or 404.59
- +3 ; IEN = pointer to team(404.51) or team position(404.57)
- +4 ; Returned:
- +5 ; -1 if error,o/w latest date defined 0=no historical dates
- +6 NEW SCX
- +7 ; gets dates as of 1/1/2999
- SET SCX=$$DATES(.FILE,.IEN,3990101)
- +8 QUIT $SELECT($PIECE(SCX,U,1)<0:-1,$PIECE(SCX,U,3):$PIECE(SCX,U,3),1:+$PIECE(SCX,U,2))
- +9 ;
- DATES(FILE,IEN,DATE) ;used to return latest activation & inactivation date
- +1 ; Input Parameters:
- +2 ; File = either 404.52, 404.53, 404.58, or 404.59
- +3 ; IEN = pointer to team(404.51) or team position(404.57)
- +4 ; DATE = default=DT
- +5 ; Returned:
- +6 ; status^actdate^inactdate^scien^first actdate? [1=yes/null=no]
- ST NEW ROOT,EFFDT,STATUS,ACTDT,INACTDT,X,FUTURE,PREVDT,SCTODAY,PREVST,SCSTAT,SCIEN,SCLAST
- +1 if '$GET(DATE)
- SET DATE=DT
- +2 SET STATUS=-1
- SET SCTODAY=0
- +3 SET SCSTAT=1
- +4 ;bp/cmf - 177 change begin
- +5 if ('$GET(FILE))!("^404.52^404.53^404.58^404.59^"'[$GET(FILE))!('$GET(IEN))
- GOTO QTDATES
- +6 ;orig;G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
- +7 ;bp/cmf - 177 change begin
- +8 SET ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
- +9 SET EFFDT=-DATE
- +10 SET X=ROOT_")"
- +11 ;if there is an active x-ref
- +12 IF $DATA(@X)
- Begin DoDot:1
- +13 ;if today is an activation date
- +14 IF $DATA(@X@(EFFDT))
- SET ACTDT=-EFFDT
- +15 ;if today is not an activation date get previous one
- +16 IF '$TEST
- Begin DoDot:2
- +17 SET ACTDT=-$ORDER(@X@(EFFDT))
- End DoDot:2
- +18 ;if no activation in past get one in future
- +19 if '$GET(ACTDT)
- SET ACTDT=-$ORDER(@X@(EFFDT),-1)
- SET FUTURE=1
- +20 SET SCSTAT=0
- +21 SET INACTDT=$ORDER(@X@(-(ACTDT-.000001)),-1)
- SET INACTDT=$SELECT(INACTDT:-INACTDT,1:INACTDT)
- +22 SET STATUS=$$DTCHK^SCAPU1(DATE,DATE,0,ACTDT,INACTDT)
- +23 SET SCSTAT=STATUS
- +24 SET X=ROOT_","_$SELECT(SCSTAT:-ACTDT,1:-INACTDT)_")"
- +25 SET SCIEN=$ORDER(@X@(0))
- End DoDot:1
- +26 IF '$TEST
- Begin DoDot:1
- +27 SET STATUS=0
- End DoDot:1
- QTDATES QUIT STATUS_U_$GET(ACTDT)_U_$GET(INACTDT)_U_$GET(SCIEN)_U_$GET(FUTURE)
- +1 ;
- ERR(SEQ,ERNUM,PARMS,OUTPUT,SCER) ;-- process errors
- +1 ;if no dialog entry 4040000 will be processed
- +2 SET ERNUM=$GET(ERNUM,4040000)
- +3 if '$$GET1^DIQ(.84,$GET(ERNUM)_",",.01)
- SET ERNUM=4040000
- +4 IF SCER]""
- Begin DoDot:1
- +5 SET SEQ=$GET(SEQ,0)+1
- +6 SET SCER(SEQ)=ERNUM
- +7 ;S @SCER@(0)=$G(@SCER@(0))+1 ;bp/djb 7/12/99
- +8 SET SCER(0)=$GET(SCER(0))+1
- +9 ;D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,.SCER) ;bp/djb 7/12/99
- +10 DO BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,"SCER")
- End DoDot:1
- +11 QUIT
- +12 ;
- OKTMPOS(TEAM,POSITION,DATE) ;validate legitimate position in a team for a dt
- +1 ; used in screen for pc practitioner position of patient team assngt
- +2 ;
- +3 ; TEAM - ien of team file
- +4 ; POSITION - ien of team position file
- +5 ; DATE - date of interest
- +6 ; return 1 if ok, 0 ow
- +7 ;
- CHK ;
- +1 NEW SCTP,SCOK,SCPOS0
- +2 SET SCOK=0
- +3 if '$LENGTH($GET(SCERR))
- SET SCERR="^TMP(""SCERR"",$J)"
- +4 IF '$DATA(^SCTM(404.51,+$GET(TEAM),0))
- Begin DoDot:1
- +5 SET SCPARM("TEAM")=$GET(TEAM,"Undefined")
- +6 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- End DoDot:1
- GOTO QTOKTP
- +7 IF '$DATA(^SCTM(404.57,+$GET(POSITION),0))
- Begin DoDot:1
- +8 SET SCPARM("POSITION")=$GET(POSITION,"Undefined")
- +9 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- End DoDot:1
- GOTO QTOKTP
- +10 IF '$GET(DATE)
- Begin DoDot:1
- +11 SET SCPARM("DATE")=$GET(DATE,"Undefined")
- +12 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- End DoDot:1
- GOTO QTOKTP
- +13 SET SCPOS0=$GET(^SCTM(404.57,POSITION,0))
- +14 ;if position not linked to team
- +15 if $PIECE(SCPOS0,U,2)'=TEAM
- GOTO QTOKTP
- +16 ;if not active position
- +17 if '$$DATES(404.59,POSITION,DATE)
- GOTO QTOKTP
- +18 SET SCOK=1
- QTOKTP QUIT SCOK
- RSNDICS(EVCODE) ; -- called by input transform and screen logic for type of reason
- +1 ; Input: EVCODE = event code (e.g. ZM1)
- +2 ; Used to check for fields that point to Scheduling Reason File
- +3 ; Piece = Piece number of zero node of
- +4 QUIT $PIECE(^SD(403.43,$PIECE(^(0),U,2),0),U,1)=EVCODE
- +5 ;
- OKPREC(TEAM) ; - called by screen logic for preceptor position file (#.1) of team position (#404.57) file
- +1 ; Input; TEAM = Pointer to team file (#404.51) for team position with preceptor
- +2 ; requires position being assigned to be a possible preceptor position
- +3 ; AND that position is from the same team as the supervised position
- +4 QUIT ($PIECE(^SCTM(404.57,Y,0),U,12))&($PIECE(^SCTM(404.57,Y,0),U,2)=TEAM)