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/ART - DD Calls used by PCMM ; 08/25/2014
  1. ;;5.3;Scheduling;**41,89,107,603,811**;AUG 13, 1993;Build 3
  1. ;
  1. ; Reference to ^ORD(101,"B" supported by DBIA 3617
  1. ;
  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. Q:'SCPTTMAF ;603
  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. K ^TMP($J,"SCTMCHG",SCPTTM)
  1. S SCPTTMB4=$G(^SCPT(404.42,SCPTTM,0))
  1. Q:'SCPTTMB4 ;603
  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. ; Input: DA - 404.42 IEN
  1. ; Returned (for de-bugging): ok?^ien of404.41^new?
  1. ; 603 - create record for all assignment types
  1. N SCNODE,SCX,DFN,SCOUTFLD,SCASSIGN
  1. S SCNODE=$G(^SCPT(404.42,+$G(DA),0))
  1. S DFN=$P(SCNODE,U,1)
  1. S SCASSIGN=$P(SCNODE,U,8)
  1. S SCOUTFLD(.04)=$S(SCASSIGN=1:"Y",SCASSIGN=98:"Y",SCASSIGN=99:"N",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,SCLP
  1. Q:'$G(SCPTTP)
  1. S SCPTTPAF=$G(^SCPT(404.43,SCPTTP,0))
  1. Q:'SCPTTPAF ;603
  1. I SCPTTPAF'["^" D ; *811 - check if SCPTTPAF contains full zero node
  1. .F SCLP=1:1:2 I SCPTTPAF'["^" H 1 S SCPTTPAF=$G(^SCPT(404.43,SCPTTP,0)) ; *811 - hang for up to 2 seconds to let full 404.43 record populate
  1. Q:SCPTTPAF'["^" ; *811 - quit if still no data after hang
  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. K ^TMP($J,"SCTPCHG",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