SCAPMC21 ;ALB/REW - Team APIs:ACPTTP ; 5 Jul 1995
;;5.3;Scheduling;**41,148,177**;AUG 13, 1993
;;1.0
ACPTTP(DFN,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
; input:
; DFN = pointer to PATIENT file (#2)
; SCTP = pointer to TEAM POSTION file (#404.57)
; SCFIELDA= array of extra field entries - scfielda('fld#')=value
; SCACT = date to activate [default=DT]
; SCERR = array NAME to store error messages.
; [ex. ^TMP("ORXX",$J)]
; SCYESTM = Should team assignment be made, if none active now?[1=YES]
; SCMAINA= array of extra field entries for 404.42 (only if scyestm=1)
;
; Output:
; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
; SCERR() = Array of DIALOG file messages(errors) .
; Foramt:
; Subscript: Sequential # from 1 to n
; Piece Description
; 1 IEN of DIALOG file
N SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA
N SCTMFLDA,SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS,SCX
G:'$$OKDATA APTTPQ ;check/setup variables
S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
;S SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
S SCAPTDT("BEGIN")=SCACT
S SCAPTDT("END")=3990101
S SCAPTDT("INCL")=0
IF $S('$D(SCFIELDA):0,'$D(@SCFIELDA@(.05)):0,($G(@SCFIELDA@(.05))=1):1,($G(@SCFIELDA@(.05))=2):1,1:0) IF '$$CHKPC(DFN) D G APTTPQ
.S SCMESS=4044300.001
;bp/cmf 177 new begin
S SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
I SCX<1 S SCMESS=$P(SCX,U,2) G APTTPQ
;bp/cmf 177 new end
G:'$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE") APTTPQ
S SCPTTPA=$O(SCAPTTPO("SCTP",SCTM,SCTP,0))
;to edit existing entry
IF SCPTTPA D G APTTPQ
.S SC($J,404.43,(+SCPTTPA)_",",.03)=SCACT
.IF $D(SCFIELDA) D
..S SCFLD=0
..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
...S SC($J,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
.D FILE^DIE("","SC($J)",SCERR)
;needed: patient team assignment for date
S SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
; if flag is set to add patient to team & no pt tm assignment exists
;
IF ('SCPTTMA)&($G(SCYESTM))&($D(SCFIELDA)) D
.S:$D(@SCFIELDA@(.05)) @SCMAINA@(.08)=$G(@SCMAINA@(.08),$S(@SCFIELDA@(.05):1,1:99))
.S:$D(@SCFIELDA@(.06)) @SCMAINA@(.11)=$G(@SCMAINA@(.11),@SCFIELDA@(.06))
.S:$D(@SCFIELDA@(.07)) @SCMAINA@(.12)=$G(@SCMAINA@(.12),@SCFIELDA@(.07))
.S:$D(@SCFIELDA@(.08)) @SCMAINA@(.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
.S:$D(@SCFIELDA@(.09)) @SCMAINA@(.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
.S SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
TM IF 'SCPTTMA G APTTPQ
ELSE D
.IF $D(SCFIELDA) D
..S SCFLD=0
..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
...S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
.S SC($J,404.43,"+1,",.01)=SCPTTMA
.S SC($J,404.43,"+1,",.02)=SCTP
.S SC($J,404.43,"+1,",.03)=SCACT
.D UPDATE^DIE("","SC($J)","SCIEN",SCERR)
.IF $D(@SCERR) K SCIEN
.ELSE D
..S SCPTTPA=+$G(SCIEN(1))
..S SCNEWTP=1
..D AFTERTP^SCMCDD1(SCPTTPA)
APTTPQ Q +$G(SCPTTPA)_U_+$G(SCNEWTP)_U_+$G(SCPTTMA)_U_+$P($G(SCPTTMA),U,2)_U_$G(SCMESS)
;
ACPTATP(DFNA,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA,SCNEWTP,SCNEWTM,SCOLDTP,SCBADTP) ;list of patients to a position (pt TP assgn - #404.43 and possibly #404.42
; input: as per ACPTTP (above with the following change:)
; DFNA = is the literal value of a patient array (e.g. "scpt"
; there is at least one scpt(dfn)="" defined
; SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position
; SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team
; SCOLDTP = Subset of DFNA that was already assigned to Position
; SCBADTP = Subset of DFNA that was NOT assigned to Position
; output: Count of Patients (New or Old) assigned to Position
N DFN,SCCNT,SCX,SCNOMAIL
S SCNOMAIL=1
S SCCNT=0
S DFN=0 F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
.S SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
.; SCX = ien of 404.43^new?^404.42 ien (new entries only)^new?
.IF $P(SCX,U,2) D ;newly assigned
..S SCCNT=SCCNT+1
..S @SCNEWTP@(DFN)=+SCX ;scnewtp
..S:$P(SCX,U,4) @SCNEWTM@(DFN)=$P(SCX,U,3) ;scnewtm
.IF $P(SCX,U,1)&('$P(SCX,U,2)) D ;old
..S SCCNT=SCCNT+1
..S @SCOLDTP@(DFN)=+SCX
.IF 'SCX D
..S @SCBADTP@(DFN)=$P(SCX,U,5)
K SCNOMAIL
D MAILLST^SCMCTPM(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP)
Q SCCNT
;
OKDATA() ;setup/check variables
N SCOK
S SCOK=1
D INIT^SCAPMCU1(.SCOK)
IF '$D(^DPT(DFN,0))!('$D(^SCTM(404.57,SCTP,0))) D S SCOK=0
. S SCPARM("PATIENT")=DFN
. S SCPARM("POSITION")=SCTP
. D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
S:'$G(SCACT) SCACT=DT
S:'$D(SCMAINA) SCMAINA="SC40443A"
Q SCOK
CHKPC(DFN) ;not stand-alone
N SCOK,SCX
S SCOK=1
G:@SCFIELDA@(.05)=0 QTCKPC ;ignore if no pc role
S SCX=$$PCRLPTTP^SCMCTPU2(DFN,SCTP,SCACT)
IF @SCFIELDA@(.05)=1 D
.S:'SCX SCOK=0
IF @SCFIELDA@(.05)=2 D
.S:'$P(SCX,U,2) SCOK=0
QTCKPC Q SCOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC21 5049 printed Apr 09, 2024@21:45:42 Page 2
SCAPMC21 ;ALB/REW - Team APIs:ACPTTP ; 5 Jul 1995
+1 ;;5.3;Scheduling;**41,148,177**;AUG 13, 1993
+2 ;;1.0
ACPTTP(DFN,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
+1 ; input:
+2 ; DFN = pointer to PATIENT file (#2)
+3 ; SCTP = pointer to TEAM POSTION file (#404.57)
+4 ; SCFIELDA= array of extra field entries - scfielda('fld#')=value
+5 ; SCACT = date to activate [default=DT]
+6 ; SCERR = array NAME to store error messages.
+7 ; [ex. ^TMP("ORXX",$J)]
+8 ; SCYESTM = Should team assignment be made, if none active now?[1=YES]
+9 ; SCMAINA= array of extra field entries for 404.42 (only if scyestm=1)
+10 ;
+11 ; Output:
+12 ; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
+13 ; SCERR() = Array of DIALOG file messages(errors) .
+14 ; Foramt:
+15 ; Subscript: Sequential # from 1 to n
+16 ; Piece Description
+17 ; 1 IEN of DIALOG file
+18 NEW SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA
+19 NEW SCTMFLDA,SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS,SCX
+20 ;check/setup variables
if '$$OKDATA
GOTO APTTPQ
+21 SET SCTM=$PIECE($GET(^SCTM(404.57,SCTP,0)),U,2)
+22 ;S SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
+23 SET SCAPTDT("BEGIN")=SCACT
+24 SET SCAPTDT("END")=3990101
+25 SET SCAPTDT("INCL")=0
+26 IF $SELECT('$DATA(SCFIELDA):0,'$DATA(@SCFIELDA@(.05)):0,($GET(@SCFIELDA@(.05))=1):1,($GET(@SCFIELDA@(.05))=2):1,1:0)
IF '$$CHKPC(DFN)
Begin DoDot:1
+27 SET SCMESS=4044300.001
End DoDot:1
GOTO APTTPQ
+28 ;bp/cmf 177 new begin
+29 SET SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
+30 IF SCX<1
SET SCMESS=$PIECE(SCX,U,2)
GOTO APTTPQ
+31 ;bp/cmf 177 new end
+32 if '$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE")
GOTO APTTPQ
+33 SET SCPTTPA=$ORDER(SCAPTTPO("SCTP",SCTM,SCTP,0))
+34 ;to edit existing entry
+35 IF SCPTTPA
Begin DoDot:1
+36 SET SC($JOB,404.43,(+SCPTTPA)_",",.03)=SCACT
+37 IF $DATA(SCFIELDA)
Begin DoDot:2
+38 SET SCFLD=0
+39 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:3
+40 SET SC($JOB,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
End DoDot:3
End DoDot:2
+41 DO FILE^DIE("","SC($J)",SCERR)
End DoDot:1
GOTO APTTPQ
+42 ;needed: patient team assignment for date
+43 SET SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
+44 ; if flag is set to add patient to team & no pt tm assignment exists
+45 ;
+46 IF ('SCPTTMA)&($GET(SCYESTM))&($DATA(SCFIELDA))
Begin DoDot:1
+47 if $DATA(@SCFIELDA@(.05))
SET @SCMAINA@(.08)=$GET(@SCMAINA@(.08),$SELECT(@SCFIELDA@(.05):1,1:99))
+48 if $DATA(@SCFIELDA@(.06))
SET @SCMAINA@(.11)=$GET(@SCMAINA@(.11),@SCFIELDA@(.06))
+49 if $DATA(@SCFIELDA@(.07))
SET @SCMAINA@(.12)=$GET(@SCMAINA@(.12),@SCFIELDA@(.07))
+50 if $DATA(@SCFIELDA@(.08))
SET @SCMAINA@(.13)=$GET(@SCMAINA@(.13),@SCFIELDA@(.08))
+51 if $DATA(@SCFIELDA@(.09))
SET @SCMAINA@(.14)=$GET(@SCMAINA@(.14),@SCFIELDA@(.09))
+52 SET SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
End DoDot:1
TM IF 'SCPTTMA
GOTO APTTPQ
+1 IF '$TEST
Begin DoDot:1
+2 IF $DATA(SCFIELDA)
Begin DoDot:2
+3 SET SCFLD=0
+4 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:3
+5 SET SC($JOB,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
End DoDot:3
End DoDot:2
+6 SET SC($JOB,404.43,"+1,",.01)=SCPTTMA
+7 SET SC($JOB,404.43,"+1,",.02)=SCTP
+8 SET SC($JOB,404.43,"+1,",.03)=SCACT
+9 DO UPDATE^DIE("","SC($J)","SCIEN",SCERR)
+10 IF $DATA(@SCERR)
KILL SCIEN
+11 IF '$TEST
Begin DoDot:2
+12 SET SCPTTPA=+$GET(SCIEN(1))
+13 SET SCNEWTP=1
+14 DO AFTERTP^SCMCDD1(SCPTTPA)
End DoDot:2
End DoDot:1
APTTPQ QUIT +$GET(SCPTTPA)_U_+$GET(SCNEWTP)_U_+$GET(SCPTTMA)_U_+$PIECE($GET(SCPTTMA),U,2)_U_$GET(SCMESS)
+1 ;
ACPTATP(DFNA,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA,SCNEWTP,SCNEWTM,SCOLDTP,SCBADTP) ;list of patients to a position (pt TP assgn - #404.43 and possibly #404.42
+1 ; input: as per ACPTTP (above with the following change:)
+2 ; DFNA = is the literal value of a patient array (e.g. "scpt"
+3 ; there is at least one scpt(dfn)="" defined
+4 ; SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position
+5 ; SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team
+6 ; SCOLDTP = Subset of DFNA that was already assigned to Position
+7 ; SCBADTP = Subset of DFNA that was NOT assigned to Position
+8 ; output: Count of Patients (New or Old) assigned to Position
+9 NEW DFN,SCCNT,SCX,SCNOMAIL
+10 SET SCNOMAIL=1
+11 SET SCCNT=0
+12 SET DFN=0
FOR
SET DFN=$ORDER(@DFNA@(DFN))
if 'DFN
QUIT
Begin DoDot:1
+13 SET SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
+14 ; SCX = ien of 404.43^new?^404.42 ien (new entries only)^new?
+15 ;newly assigned
IF $PIECE(SCX,U,2)
Begin DoDot:2
+16 SET SCCNT=SCCNT+1
+17 ;scnewtp
SET @SCNEWTP@(DFN)=+SCX
+18 ;scnewtm
if $PIECE(SCX,U,4)
SET @SCNEWTM@(DFN)=$PIECE(SCX,U,3)
End DoDot:2
+19 ;old
IF $PIECE(SCX,U,1)&('$PIECE(SCX,U,2))
Begin DoDot:2
+20 SET SCCNT=SCCNT+1
+21 SET @SCOLDTP@(DFN)=+SCX
End DoDot:2
+22 IF 'SCX
Begin DoDot:2
+23 SET @SCBADTP@(DFN)=$PIECE(SCX,U,5)
End DoDot:2
End DoDot:1
+24 KILL SCNOMAIL
+25 DO MAILLST^SCMCTPM(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP)
+26 QUIT SCCNT
+27 ;
OKDATA() ;setup/check variables
+1 NEW SCOK
+2 SET SCOK=1
+3 DO INIT^SCAPMCU1(.SCOK)
+4 IF '$DATA(^DPT(DFN,0))!('$DATA(^SCTM(404.57,SCTP,0)))
Begin DoDot:1
+5 SET SCPARM("PATIENT")=DFN
+6 SET SCPARM("POSITION")=SCTP
+7 DO ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
SET SCOK=0
+8 if '$GET(SCACT)
SET SCACT=DT
+9 if '$DATA(SCMAINA)
SET SCMAINA="SC40443A"
+10 QUIT SCOK
CHKPC(DFN) ;not stand-alone
+1 NEW SCOK,SCX
+2 SET SCOK=1
+3 ;ignore if no pc role
if @SCFIELDA@(.05)=0
GOTO QTCKPC
+4 SET SCX=$$PCRLPTTP^SCMCTPU2(DFN,SCTP,SCACT)
+5 IF @SCFIELDA@(.05)=1
Begin DoDot:1
+6 if 'SCX
SET SCOK=0
End DoDot:1
+7 IF @SCFIELDA@(.05)=2
Begin DoDot:1
+8 if '$PIECE(SCX,U,2)
SET SCOK=0
End DoDot:1
QTCKPC QUIT SCOK
