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

SCMCDD1.m

Go to the documentation of this file. 
  1. SCMCDD1 ;ALB/REW - DD Calls used by PCMM ; 6 November 1995
  1.  ;;5.3;Scheduling;**41,89,107,1015**;AUG 13, 1993;Build 21
  1.  ;1
  1. WRITETP(SCTP) ;used by write node of 404.57
  1.  N SCCL
  1.  S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
  1.  Q $P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"  "_$P($G(^SC(+$G(SCCL),0)),U,1)
  1.  ;
  1. SETPTTM(SCPTTMA) ;delete
  1.  Q
  1.  ;
  1. KILLPTTM(SCPTTMA) ;delete
  1.  Q
  1.  ;
  1. AFTERTM(SCPTTM) ;called after update of 404.42
  1.  N SCPTTMB4,SCPCTMB4,SCTMB4,SCTMNDB4,SCPTTMAF,SCPCTMAF,SCTMAF,X,SCFLD,SCX,SCTMNDAF,SCTMNMB4,Y
  1.  Q:'$G(SCPTTM)
  1.  S SCPTTMAF=$G(^SCPT(404.42,SCPTTM,0))
  1.  S SCPCTMAF=$S(($P(SCPTTMAF,U,8)=1):1,1:0)
  1.  S SCTMAF=$P(SCPTTMAF,U,3)
  1.  S:SCTMAF SCTMNDAF=$G(^SCTM(404.51,SCTMAF,0))
  1.  F X="SCPTTMB4","SCPCTMB4","SCTMB4","SCTMNMB4" S @X=$G(^TMP($J,"SCTMCHG",SCPTTM,X))
  1.  F SCFLD=1:1:14 S SCX=$P(SCPTTMAF,U,SCFLD) S:SCX'="" ^TMP($J,"SCTMCHG",SCPTTM,"AF",(SCFLD*.01))=SCX
  1.  S X=+$O(^ORD(101,"B","SCMC PATIENT TEAM CHANGES",0))_";ORD(101,"
  1.  D:SCPTTMAF'=SCPTTMB4 EN^XQOR
  1.  K ^TMP($J,"SCTMCHG",SCPTTM)
  1.  Q
  1.  ;
  1. BEFORETM(SCPTTM) ;called before update of 404.42
  1.  N SCPTTMB4,SCPCTMB4,SCTMB4,SCTMNDB4,X,SCFLD,SCX,SCY,DR,DIC,DA,DIQ
  1.  Q:'$G(SCPTTM)
  1.  S SCPTTMB4=$G(^SCPT(404.42,SCPTTM,0))
  1.  S SCPCTMB4=$S(($P(SCPTTMB4,U,8)=1):1,1:0)
  1.  S SCTMB4=$P(SCPTTMB4,U,3)
  1.  S:SCTMB4 SCTMNDB4=$G(^SCTM(404.51,SCTMB4,0))
  1.  F X="SCPTTMB4","SCPCTMB4","SCTMB4","SCTMNDB4" S ^TMP($J,"SCTMCHG",SCPTTM,X)=$G(@X)
  1.  F SCY=1:1:14 S SCX=$P(SCPTTMB4,U,SCY) IF SCX'="" D
  1.  .S SCFLD=SCY*.01
  1.  .S ^TMP($J,"SCTMCHG",SCPTTM,"B4",SCFLD)=SCX
  1.  Q
  1.  ;
  1. SETPC(SC1,SC2,SC3,SC4,DA)  ;APCPOS xref for 404.43
  1.  ;DFN = Pointer to Patient File
  1.  ;SC1 = pointer to 404.42
  1.  ;SC2 = ROLE (1=pc practitioner,2=pc attending)
  1.  ;SC3 = Activation Date
  1.  ;SC4 = Team Position
  1.  N DFN
  1.  S DFN=$P($G(^SCPT(404.42,SC1,0)),U,1)
  1.  S:DFN&SC1&SC2&SC3&SC4&DA ^SCPT(404.43,"APCPOS",DFN,SC2,SC3,SC4,DA)=""
  1.  Q
  1. KILLPC(SC1,SC2,SC3,SC4,DA) ;APCPOS xref for 404.43
  1.  ;DFN = Pointer to Patient File
  1.  ;SC1 = pointer to 404.42
  1.  ;SC2 = ROLE (1=pc practitioner,2=pc attending)
  1.  ;SC3 = Activation Date
  1.  ;SC4 = Team Position
  1.  N DFN
  1.  S DFN=$P($G(^SCPT(404.42,SC1,0)),U,1)
  1.  K:DFN&SC1&SC2&SC3&SC4&DA ^SCPT(404.43,"APCPOS",DFN,SC2,SC3,SC4,DA)
  1.  Q
  1.  ;
  1. MAKEMANY(DFNA,SCOLDASS,SCBADASS,SCNEWASS) ;Not supported for use by PCMM Only - sets PC field to YES
  1.  ;   DFNA    - DFN ARRAY
  1.  ;   SCOLDASS - Subset of DFNA that were previously assigned
  1.  ;   SCBADASS - Subset of DFNA that could not be assigned
  1.  ;   SCNEWASS - Subset of DFNA that were newly assigned
  1.  ;   Returned: total^new^old^bad
  1.  ; Note: No input error checking!!
  1.  N DFN,SCX,SCOUTFLD,SCBADOUT,SCOLDCNT,SCBADCNT,SCNEWCNT
  1.  S (SCBADCNT,SCOLDCNT,SCNEWCNT)=0
  1.  S DFN=0
  1.  F  S DFN=$O(@DFNA@(DFN)) Q:'DFN  D
  1.  .S SCOUTFLD(.04)=1
  1.  .S SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
  1.  .;SCX=OK?^p404.41^new?
  1.  .IF 'SCX D
  1.  ..S SCBADCNT=SCBADCNT+1
  1.  ..S @SCBADASS@(DFN)=""
  1.  .ELSE  D
  1.  ..IF $P(SCX,U,3) D
  1.  ...S SCNEWCNT=SCNEWCNT+1
  1.  ...S @SCNEWASS@(DFN)=""
  1.  ..ELSE  D
  1.  ...S SCOLDCNT=SCOLDCNT+1
  1.  ...S @SCOLDASS@(DFN)=""
  1.  Q (SCOLDCNT+SCNEWCNT)_U_SCNEWCNT_U_SCOLDCNT_U_SCBADCNT
  1.  ;
  1. MAKEOUT(DA) ;used by 404.42 to create an outpatient profile entry (if there wasn't one) and set the PRIMARY CARE?(.04) field to YES
  1.  ;  Returned (for de-bugging): ok?^ien of404.41^new?
  1.  N SCNODE,SCX,DFN,SCOUTFLD
  1.  S SCNODE=$G(^SCPT(404.42,+$G(DA),0))
  1.  S DFN=$P(SCNODE,U,1)
  1.  IF $P(SCNODE,U,8)=1 D  ;if assignment was to primary care
  1.  .S SCOUTFLD(.04)=1
  1.  .S SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
  1.  Q $G(SCX)
  1.  ;
  1. AFTERTP(SCPTTP) ;called after update of 404.43
  1.  N SCPTTPB4,SCPCTPB4,SCTPB4,SCTPNDB4,SCPTTPAF,SCPCTPAF,SCTPAF,X,SCFLD,SCX,SCTMB4,SCTMNDB4,SCTMNDAF,SCTMAF,SCPTNM,SCTPNDAF,SCTPNMB4,Y
  1.  Q:'$G(SCPTTP)
  1.  S SCPTTPAF=$G(^SCPT(404.43,SCPTTP,0))
  1.  S SCPCTPAF=+$P(SCPTTPAF,U,5)
  1.  S SCTPAF=$P(SCPTTPAF,U,2)
  1.  S:SCTPAF SCTPNDAF=$G(^SCTM(404.57,SCTPAF,0))
  1.  S:SCTPAF SCTMAF=$P(SCTPNDAF,U,2)
  1.  S:SCTMAF SCTMNDAF=$G(^SCTM(404.51,SCTMAF,0))
  1.  F X="SCPTTPB4","SCPCTPB4","SCTPB4","SCTPNMB4","SCTMB4","SCTMNDB4" S @X=$G(^TMP($J,"SCTPCHG",SCPTTP,X))
  1.  F SCFLD=1:1:9 S SCX=$P(SCPTTPAF,U,SCFLD) S:SCX'="" ^TMP($J,"SCTPCHG",SCPTTP,"AF",(SCFLD*.01))=SCX
  1.  S X=+$O(^ORD(101,"B","SCMC PATIENT TEAM POSITION CHANGES",0))_";ORD(101,"
  1.  D:SCPTTPAF'=SCPTTPB4 EN^XQOR
  1.  K ^TMP($J,"SCTPCHG",SCPTTP)
  1.  Q
  1.  ;
  1. BEFORETP(SCPTTP) ;called before update of 404.43
  1.  N SCPTTPB4,SCPCTPB4,SCTPB4,SCTPNDB4,X,SCFLD,SCX,SCY,DR,DIC,DA,DIQ,SCTMB4,SCTMNDAF,SCTMNDB4,SCTMNMB4
  1.  Q:'$G(SCPTTP)
  1.  S SCPTTPB4=$G(^SCPT(404.43,SCPTTP,0))
  1.  Q:'SCPTTPB4
  1.  S SCPCTPB4=+$P(SCPTTPB4,U,5)
  1.  S SCTPB4=$P(SCPTTPB4,U,2)
  1.  S:SCTPB4 SCTPNDB4=$G(^SCTM(404.57,SCTPB4,0))
  1.  S:SCTPB4 SCTMB4=$P(SCTPNDB4,U,2)
  1.  S:SCTMB4 SCTMNDB4=$G(^SCTM(404.51,SCTMB4,0))
  1.  F X="SCPTTPB4","SCPCTPB4","SCTPB4","SCTPNDB4","SCTMNDB4","SCTMB4" S ^TMP($J,"SCTPCHG",SCPTTP,X)=$G(@X)
  1.  F SCY=1:1:9 S SCX=$P(SCPTTPB4,U,SCY) IF SCX'="" D
  1.  .S SCFLD=SCY*.01
  1.  .S ^TMP($J,"SCTPCHG",SCPTTP,"B4",SCFLD)=SCX
  1.  Q