- SCMCBK8 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1;;Aug 7, 1998
- ;;5.3;Scheduling;**148,177,210,1015**;AUG 13, 1993;Build 21
- Q
- ;
- 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,SCTMFLDA
- N SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS
- N SCLOCK,SCXLOCK,SCX
- ;
- ;check/setup variables
- I '$$OKDATA^SCAPMC21 S SCMESS=$$S(9) G APTTPQ
- ;
- ;bp/cmf 210 new begin
- ;lock process/dfn/pos
- I '$D(^XTMP("SCMC POS ASGN")) D
- . S ^XTMP("SCMC POS ASGN",0)=DT_U_DT_U_"POS ASGN PROCESS LOCK"
- . Q
- ;
- S SCXLOCK=0
- S SCLOCK="^XTMP(""SCMC POS ASGN"",DFN)"
- I $D(@SCLOCK) S SCMESS=$$S(15) G APTTPQ
- S @SCLOCK=""
- S SCXLOCK=1
- H 1
- ;
- ;stop if active assignment
- S SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
- I SCPTTPA S SCMESS=$$S(10) G APTTPQ
- ;bp/cmf 210 new end
- ;
- S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
- S SCAPTDT("BEGIN")=SCACT
- S SCAPTDT("END")=3990101
- S SCAPTDT("INCL")=0
- ;
- ;is patient alive?
- I $$DP^SCMCBK6(DFN) S SCMESS=$$S(1) G APTTPQ
- ;
- S SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
- I SCX<1 S SCMESS=$P(SCX,U,2) G APTTPQ
- ;
- ;is PC role assignable?
- I $$T1(),'$$CHKPC^SCAPMC21(DFN) S SCMESS=$$S(12) G APTTPQ
- ;
- I '$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE") S SCMESS=$$S(13) G APTTPQ
- S SCPTTPA=$O(SCAPTTPO("SCTP",SCTM,SCTP,0))
- ;
- ;to edit existing entry
- I SCPTTPA D G APTTPQ
- .S SC($J,404.43,(+SCPTTPA)_",",.03)=SCACT
- .I $D(SCFIELDA) D
- ..S SCFLD=0
- ..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
- ...S SC($J,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
- ...Q
- ..Q
- .D FILE^DIE("","SC($J)",SCERR)
- .Q
- ;
- ;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
- I ('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)
- .Q
- ;
- TM I 'SCPTTMA S SCMESS=$$S(14) G APTTPQ
- ;
- I $D(SCFIELDA) D
- .S SCFLD=0
- .F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
- ..S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
- ..Q
- .Q
- ;
- S SC($J,404.43,"+1,",.01)=SCPTTMA
- S SC($J,404.43,"+1,",.02)=SCTP
- S SC($J,404.43,"+1,",.03)=SCACT
- N SCTPERR
- D UPDATE^DIE("","SC($J)","SCIEN","SCTPERR")
- ;
- I $D(SCTPERR) S SCMESS=$$S(11) K SCIEN
- E D
- .S SCPTTPA=+$G(SCIEN(1))
- .S SCNEWTP=1
- .D AFTERTP^SCMCDD1(SCPTTPA)
- .Q
- ;
- APTTPQ ;bp/cmf 210 new code begin
- I SCXLOCK=1 K @SCLOCK
- ;bp/cmf 210 new code end
- Q +$G(SCPTTPA)_U_+$G(SCNEWTP)_U_+$G(SCPTTMA)_U_+$P($G(SCPTTMA),U,2)_U_$G(SCMESS)
- ;
- T1() Q $S('$D(SCFIELDA):0,'$D(@SCFIELDA@(.05)):0,($G(@SCFIELDA@(.05))=1):1,($G(@SCFIELDA@(.05))=2):1,1:0)
- ;
- S(SCX) Q $$S^SCMCBK6(SCX)
- ;
- 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,SCTOTCNT
- S SCNOMAIL=1
- S SCCNT=0
- S SCTOTCNT=$$PASSCNT^SCMCBK5(DFNA)
- I SCTOTCNT=0 G MAIL
- S DFN=0
- F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
- .S SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
- .;
- .;newly assigned
- .I $P(SCX,U,2)=1 D Q
- ..S SCCNT=SCCNT+1
- ..S @SCNEWTP@(DFN)=+SCX
- ..S:$P(SCX,U,4) @SCNEWTM@(DFN)=$P(SCX,U,3)
- ..Q
- .;
- .;already assigned
- .;I $P(SCX,U,1)&('$P(SCX,U,2)) D
- .I +SCX D Q
- ..S SCCNT=SCCNT+1
- ..S @SCOLDTP@(DFN)=+SCX
- ..Q
- .;
- .;not assigned;;I 'SCX D
- .S @SCBADTP@(DFN)=$P(SCX,U,5)
- .Q
- ;
- MAIL K SCNOMAIL
- D MAILLST^SCMCBK9(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP,SCTOTCNT)
- Q SCCNT
- ;
- SCMCBK8 ;bp/cmf - multiple patient assignments mail queue - RPCVersion = 1;;Aug 7, 1998
- +1 ;;5.3;Scheduling;**148,177,210,1015**;AUG 13, 1993;Build 21
- +2 QUIT
- +3 ;
- 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 ;
- +19 NEW SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA,SCTMFLDA
- +20 NEW SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS
- +21 NEW SCLOCK,SCXLOCK,SCX
- +22 ;
- +23 ;check/setup variables
- +24 IF '$$OKDATA^SCAPMC21
- SET SCMESS=$$S(9)
- GOTO APTTPQ
- +25 ;
- +26 ;bp/cmf 210 new begin
- +27 ;lock process/dfn/pos
- +28 IF '$DATA(^XTMP("SCMC POS ASGN"))
- Begin DoDot:1
- +29 SET ^XTMP("SCMC POS ASGN",0)=DT_U_DT_U_"POS ASGN PROCESS LOCK"
- +30 QUIT
- End DoDot:1
- +31 ;
- +32 SET SCXLOCK=0
- +33 SET SCLOCK="^XTMP(""SCMC POS ASGN"",DFN)"
- +34 IF $DATA(@SCLOCK)
- SET SCMESS=$$S(15)
- GOTO APTTPQ
- +35 SET @SCLOCK=""
- +36 SET SCXLOCK=1
- +37 HANG 1
- +38 ;
- +39 ;stop if active assignment
- +40 SET SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
- +41 IF SCPTTPA
- SET SCMESS=$$S(10)
- GOTO APTTPQ
- +42 ;bp/cmf 210 new end
- +43 ;
- +44 SET SCTM=$PIECE($GET(^SCTM(404.57,SCTP,0)),U,2)
- +45 SET SCAPTDT("BEGIN")=SCACT
- +46 SET SCAPTDT("END")=3990101
- +47 SET SCAPTDT("INCL")=0
- +48 ;
- +49 ;is patient alive?
- +50 IF $$DP^SCMCBK6(DFN)
- SET SCMESS=$$S(1)
- GOTO APTTPQ
- +51 ;
- +52 SET SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
- +53 IF SCX<1
- SET SCMESS=$PIECE(SCX,U,2)
- GOTO APTTPQ
- +54 ;
- +55 ;is PC role assignable?
- +56 IF $$T1()
- IF '$$CHKPC^SCAPMC21(DFN)
- SET SCMESS=$$S(12)
- GOTO APTTPQ
- +57 ;
- +58 IF '$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE")
- SET SCMESS=$$S(13)
- GOTO APTTPQ
- +59 SET SCPTTPA=$ORDER(SCAPTTPO("SCTP",SCTM,SCTP,0))
- +60 ;
- +61 ;to edit existing entry
- +62 IF SCPTTPA
- Begin DoDot:1
- +63 SET SC($JOB,404.43,(+SCPTTPA)_",",.03)=SCACT
- +64 IF $DATA(SCFIELDA)
- Begin DoDot:2
- +65 SET SCFLD=0
- +66 FOR
- SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
- IF 'SCFLD
- QUIT
- Begin DoDot:3
- +67 SET SC($JOB,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
- +68 QUIT
- End DoDot:3
- +69 QUIT
- End DoDot:2
- +70 DO FILE^DIE("","SC($J)",SCERR)
- +71 QUIT
- End DoDot:1
- GOTO APTTPQ
- +72 ;
- +73 ;needed: patient team assignment for date
- +74 SET SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
- +75 ;
- +76 ; if flag is set to add patient to team & no pt tm assignment exists
- +77 IF ('SCPTTMA)&($GET(SCYESTM))&($DATA(SCFIELDA))
- Begin DoDot:1
- +78 IF $DATA(@SCFIELDA@(.05))
- SET @SCMAINA@(.08)=$GET(@SCMAINA@(.08),$SELECT(@SCFIELDA@(.05):1,1:99))
- +79 IF $DATA(@SCFIELDA@(.06))
- SET @SCMAINA@(.11)=$GET(@SCMAINA@(.11),@SCFIELDA@(.06))
- +80 IF $DATA(@SCFIELDA@(.07))
- SET @SCMAINA@(.12)=$GET(@SCMAINA@(.12),@SCFIELDA@(.07))
- +81 IF $DATA(@SCFIELDA@(.08))
- SET @SCMAINA@(.13)=$GET(@SCMAINA@(.13),@SCFIELDA@(.08))
- +82 IF $DATA(@SCFIELDA@(.09))
- SET @SCMAINA@(.14)=$GET(@SCMAINA@(.14),@SCFIELDA@(.09))
- +83 SET SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
- +84 QUIT
- End DoDot:1
- +85 ;
- TM IF 'SCPTTMA
- SET SCMESS=$$S(14)
- GOTO APTTPQ
- +1 ;
- +2 IF $DATA(SCFIELDA)
- Begin DoDot:1
- +3 SET SCFLD=0
- +4 FOR
- SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
- IF 'SCFLD
- QUIT
- Begin DoDot:2
- +5 SET SC($JOB,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
- +6 QUIT
- End DoDot:2
- +7 QUIT
- End DoDot:1
- +8 ;
- +9 SET SC($JOB,404.43,"+1,",.01)=SCPTTMA
- +10 SET SC($JOB,404.43,"+1,",.02)=SCTP
- +11 SET SC($JOB,404.43,"+1,",.03)=SCACT
- +12 NEW SCTPERR
- +13 DO UPDATE^DIE("","SC($J)","SCIEN","SCTPERR")
- +14 ;
- +15 IF $DATA(SCTPERR)
- SET SCMESS=$$S(11)
- KILL SCIEN
- +16 IF '$TEST
- Begin DoDot:1
- +17 SET SCPTTPA=+$GET(SCIEN(1))
- +18 SET SCNEWTP=1
- +19 DO AFTERTP^SCMCDD1(SCPTTPA)
- +20 QUIT
- End DoDot:1
- +21 ;
- APTTPQ ;bp/cmf 210 new code begin
- +1 IF SCXLOCK=1
- KILL @SCLOCK
- +2 ;bp/cmf 210 new code end
- +3 QUIT +$GET(SCPTTPA)_U_+$GET(SCNEWTP)_U_+$GET(SCPTTMA)_U_+$PIECE($GET(SCPTTMA),U,2)_U_$GET(SCMESS)
- +4 ;
- T1() QUIT $SELECT('$DATA(SCFIELDA):0,'$DATA(@SCFIELDA@(.05)):0,($GET(@SCFIELDA@(.05))=1):1,($GET(@SCFIELDA@(.05))=2):1,1:0)
- +1 ;
- S(SCX) QUIT $$S^SCMCBK6(SCX)
- +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 ;
- +10 NEW DFN,SCCNT,SCX,SCNOMAIL,SCTOTCNT
- +11 SET SCNOMAIL=1
- +12 SET SCCNT=0
- +13 SET SCTOTCNT=$$PASSCNT^SCMCBK5(DFNA)
- +14 IF SCTOTCNT=0
- GOTO MAIL
- +15 SET DFN=0
- +16 FOR
- SET DFN=$ORDER(@DFNA@(DFN))
- IF 'DFN
- QUIT
- Begin DoDot:1
- +17 SET SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
- +18 ;
- +19 ;newly assigned
- +20 IF $PIECE(SCX,U,2)=1
- Begin DoDot:2
- +21 SET SCCNT=SCCNT+1
- +22 SET @SCNEWTP@(DFN)=+SCX
- +23 IF $PIECE(SCX,U,4)
- SET @SCNEWTM@(DFN)=$PIECE(SCX,U,3)
- +24 QUIT
- End DoDot:2
- QUIT
- +25 ;
- +26 ;already assigned
- +27 ;I $P(SCX,U,1)&('$P(SCX,U,2)) D
- +28 IF +SCX
- Begin DoDot:2
- +29 SET SCCNT=SCCNT+1
- +30 SET @SCOLDTP@(DFN)=+SCX
- +31 QUIT
- End DoDot:2
- QUIT
- +32 ;
- +33 ;not assigned;;I 'SCX D
- +34 SET @SCBADTP@(DFN)=$PIECE(SCX,U,5)
- +35 QUIT
- End DoDot:1
- +36 ;
- MAIL KILL SCNOMAIL
- +1 DO MAILLST^SCMCBK9(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP,SCTOTCNT)
- +2 QUIT SCCNT
- +3 ;