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

SCMCTSKG.m

Go to the documentation of this file. 
  1. SCMCTSKG ;bpoifo/dmr PCMM Inactivation GUI Rpt.;3/18/08
  1.  ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
  1.  ;;
  1. EN(SCRESULT,SCARRAY) ;
  1.  S (STAT,TN,IEN,INST,INSTN,UNDATE,UNREA,TEAMPN,SSN,SSNN)="" S NUM=0
  1.  S (TEAM,TEAMP,PROVN,PROV,BDATE,EDATE,PAT,INAME,HOLD)="" S NN=0,CC=0,CT=0
  1.  K ^TMP("SCARRAY")
  1.  M ^TMP("SCARRAY")=SCARRAY
  1.  D DATE
  1.  K ^TMP("SCRESULT","B")
  1.  D FINAL
  1.  S SCRESULT=$NA(^TMP("SCRESULT"))
  1.  D EXIT
  1.  Q
  1. DATE ;
  1.  S BDATE=$G(^TMP("SCARRAY","AA")) S X=$P(BDATE,"""",2) D ^%DT S BDATE=Y
  1.  S EDATE=$G(^TMP("SCARRAY","AB")) S X=$P(EDATE,"""",2) D ^%DT S EDATE=Y
  1.  D START
  1.  Q
  1. START ;
  1.  S STAT="" F  S STAT=$O(^SCPT(404.43,"ASTATB",STAT)) Q:STAT=""  D
  1.  .S IEN=""  F  S IEN=$O(^SCPT(404.43,"ASTATB",STAT,IEN)) Q:'IEN  D
  1.  ..S UNDATE="" S UNDATE=$$GET1^DIQ(404.43,IEN_",",.04,"I") IF $D(UNDATE) D
  1.  ...I (UNDATE<BDATE)!(UNDATE>EDATE) Q
  1.  ...S PAT="" S PAT=$$GET1^DIQ(404.43,IEN_",",.01)
  1.  ...S (SN,SSN,SSNN)="" S SN=$$GET1^DIQ(404.43,IEN_",",.01,"I")
  1.  ...S SSNN=$$GET1^DIQ(404.42,SN_",",.01,"I") S SSN=$$GET1^DIQ(2,SSNN_",",.09)
  1.  ...D TEAMP
  1.  ...Q
  1.  Q
  1. TEAMP ;
  1.  S (TEAMP,TPN,TPN2)=""
  1.  S TPN=$$GET1^DIQ(404.43,IEN_",",.02,"I")
  1.  S TEAMP=$$GET1^DIQ(404.43,IEN_",",.02)
  1.  I $G(^TMP("SCARRAY","TP^0"))="""ALL^0""" D TEAM Q
  1.  I '$D(^TMP("SCARRAY","TP^0")) D
  1.  .S TPN2=$G(^TMP("SCARRAY","TP^"_TPN)) I TPN2'="" D
  1.  ..S TPN2=$P(TPN2,"""",2) I $P(TPN2,"^",1)=TEAMP D TEAM
  1.  Q
  1. TEAM ;
  1.  S (TEAMN,TN,TN2,PREC)=""
  1.  S TN=$$GET1^DIQ(404.57,TPN_",",.02,"I")
  1.  S TEAMN=$$GET1^DIQ(404.57,TPN_",",.02)
  1.  S PREC=$$GET1^DIQ(404.57,TPN_",",.1)
  1.  I $G(^TMP("SCARRAY","T^0"))="""ALL^0""" D INST
  1.  I '$D(^TMP("SCARRAY","T^0")) D
  1.  .S TN2=$G(^TMP("SCARRAY","T^"_TN)) I TN2'="" D
  1.  ..S TN2=$P(TN2,"""",2),TN2=$P(TN2,"^",1)
  1.  ..I TN2=TEAMN D INST
  1.  Q
  1. INST ;
  1.  S (INST,INSTN,INUM)=""
  1.  S INSTN=$$GET1^DIQ(404.51,TN_",",.07,"I")
  1.  I $G(^TMP("SCARRAY","D^0"))="""ALL^0""" D
  1.  .S INST=$$GET1^DIQ(404.51,TN_",",.07)
  1.  .D PROV
  1.  .Q
  1.  I $G(^TMP("SCARRAY","D^0"))'="""ALL""" D
  1.  .S INUM=$G(^TMP("SCARRAY","D^"_INSTN)) I INUM'="" D
  1.  ..S INUM=$P(INUM,"""",2)
  1.  ..I $P(INUM,"^",2)=INSTN D
  1.  ...S INST=$$GET1^DIQ(404.51,TN_",",.07)
  1.  ...D PROV
  1.  ...Q
  1.  Q
  1. PROV ;
  1.  S (PROV,PROVN,J,JJ,PDATE,EFFD,SCLIST,ERROR,FILE,ST,P1,P2,P3)=""
  1.  I $G(^TMP("SCARRAY","P^0"))'="""ALL^0""" D
  1.  .S J="N" F  S J=$O(^TMP("SCARRAY",J)) Q:J=""  D
  1.  ..Q:$P(J,"^",1)'="P"  D
  1.  ...S PROVN="" S PROVN=+$P(^TMP("SCARRAY",J),"^",2) D
  1.  ....S JJ="" F  S JJ=$O(^SCTM(404.52,"C",PROVN,JJ)) Q:'JJ  D
  1.  .....S POS="" S POS=$$GET1^DIQ(404.52,JJ_",",.01) I POS=TEAMP D
  1.  ......S (PDATE,ST)="" S PDATE=$$GET1^DIQ(404.52,JJ_",",.02,"I"),ST=$$GET1^DIQ(404.52,JJ_",",.04,"I") D
  1.  .......I PDATE>UNDATE Q
  1.  .......I ST=0&(PDATE<UNDATE) Q
  1.  .......S PROV="" S PROV=$$GET1^DIQ(404.52,JJ_",",.03)
  1.  .......D UNREA,SAVE
  1.  .......Q
  1.  I $G(^TMP("SCARRAY","P^0"))="""ALL^0""" D
  1.  .S PROVN="" F  S PROVN=$O(^SCTM(404.52,"C",PROVN)) Q:PROVN=""  D
  1.  ..S JJ="" F  S JJ=$O(^SCTM(404.52,"C",PROVN,JJ)) Q:'JJ  D
  1.  ...S POS="" S POS=$$GET1^DIQ(404.52,JJ_",",.01) I POS=TEAMP D
  1.  ....S (PDATE,ST)="" S PDATE=$$GET1^DIQ(404.52,JJ_",",.02,"I"),ST=$$GET1^DIQ(404.52,JJ_",",.04,"I") D
  1.  .....I PDATE>UNDATE Q
  1.  .....I ST=0&(PDATE<UNDATE) Q
  1.  .....S PROV="" S PROV=$$GET1^DIQ(404.52,JJ_",",.03)
  1.  .....D UNREA,SAVE
  1.  .....Q
  1.  Q
  1. UNREA ;Unassign Reason
  1.  S UNREA=""
  1.  S UNREA=$$GET1^DIQ(404.43,IEN_",",.12,"I")
  1.  Q
  1. SAVE ;
  1.  I $G(^TMP("SCARRAY","S1"))="""ALL""" D SAVE1 Q
  1.  I $G(^TMP("SCARRAY","S1"))'="""ALL""" D SAVE2,SAVE3
  1.  Q
  1. SAVE1 ;
  1.  S Y=UNDATE D DD^%DT S UNDATE=Y
  1.  S NUM=NUM+1
  1.  S ^TMP("SCRESULT",INST,PAT,NUM)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE_"^"_UNREA
  1.  Q
  1. SAVE2 ;
  1.  S (S1,S2,S3,S4,S5,S6,S7)="",CC="",SORT=""
  1.  F NN=1:1:7 S SORT=$G(^TMP("SCARRAY","S"_NN)) Q:SORT=""  D
  1.  .S SORT=$P(SORT,"""",2)
  1.  .S XX=$S(SORT="Patient":PAT,SORT="Institution":INST,SORT="Team":TEAMN,SORT="Provider":PROV,SORT="Team Position":TEAMP,SORT="Date":UNDATE,SORT="Reason":UNREA,1:"")
  1.  .S HOLD=NN
  1.  .I NN=1 S S1=XX,^TMP("SCRESULT",S1)=""
  1.  .I NN=2 S S2=XX,^TMP("SCRESULT",S1,S2)=""
  1.  .I NN=3 S S3=XX,^TMP("SCRESULT",S1,S2,S3)=""
  1.  .I NN=4 S S4=XX,^TMP("SCRESULT",S1,S2,S3,S4)=""
  1.  .I NN=5 S S5=XX,^TMP("SCRESULT",S1,S2,S3,S4,S5)=""
  1.  .I NN=6 S S6=XX,^TMP("SCRESULT",S1,S2,S3,S4,S5,S6)=""
  1.  .I NN=7 S S7=XX,^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7)=""
  1.  Q
  1. SAVE3 ;
  1.  S CC=$S(HOLD=1:"SORT1",HOLD=2:"SORT2",HOLD=3:"SORT3",HOLD=4:"SORT4",HOLD=5:"SORT5",HOLD=6:"SORT6",HOLD=7:"SORT7",1:"")
  1.  S UNDATE2="" S UNDATE2=UNDATE
  1.  S Y=UNDATE2 D DD^%DT S UNDATE2=Y
  1.  D @CC
  1.  Q
  1. SORT1 ;
  1.  I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
  1.  S CT=CT+1
  1.  S ^TMP("SCRESULT",S1,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
  1.  S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
  1.  Q
  1. SORT2 ;
  1.  I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
  1.  S CT=CT+1
  1.  S ^TMP("SCRESULT",S1,S2,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
  1.  S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
  1.  Q
  1. SORT3 ;
  1.  I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
  1.  S CT=CT+1
  1.  S ^TMP("SCRESULT",S1,S2,S3,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
  1.  S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
  1.  Q
  1. SORT4 ;
  1.  I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
  1.  S CT=CT+1
  1.  S ^TMP("SCRESULT",S1,S2,S3,S4,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
  1.  S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
  1.  Q
  1. SORT5 ;
  1.  I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
  1.  S CT=CT+1
  1.  S ^TMP("SCRESULT",S1,S2,S3,S4,S5,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
  1.  S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
  1.  Q
  1. SORT6 ;
  1.  I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
  1.  S CT=CT+1
  1.  S ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
  1.  S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
  1.  Q
  1. SORT7 ;
  1.  I $D(^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)) Q
  1.  S CT=CT+1
  1.  S ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,CT)=PAT_"^"_SSN_"^"_INST_"^"_TEAMN_"^"_PROV_"^"_TEAMP_"^"_PREC_"^"_UNDATE2_"^"_UNREA
  1.  S ^TMP("SCRESULT","B",PAT,SSN,INST,TEAMN)=""
  1.  Q
  1. FINAL ;
  1.  I $G(^TMP("SCARRAY","S1"))="""ALL""" D
  1.  .S (INST,PAT,NUM)="" S CC=0,C=0
  1.  .S INST="" F  S INST=$O(^TMP("SCRESULT",INST)) Q:INST=""  D
  1.  ..S PAT="" F  S PAT=$O(^TMP("SCRESULT",INST,PAT)) Q:PAT=""  D
  1.  ...S NUM="" F  S NUM=$O(^TMP("SCRESULT",INST,PAT,NUM)) Q:NUM=""  D
  1.  ....S CC=CC+1 S ^TMP("SCRESULT",CC)=^TMP("SCRESULT",INST,PAT,NUM)
  1.  ....K ^TMP("SCRESULT",INST,PAT,NUM)
  1.  I $G(^TMP("SCARRAY","S1"))'="""ALL""" D
  1.  .S (S1,S2,S3,S4,S5,S6,S7)="",CT=0,C=0
  1.  .IF CC="SORT1" D
  1.  ..S S1="" F  S S1=$O(^TMP("SCRESULT",S1)) Q:S1=""  D
  1.  ...S C="" F  S C=$O(^TMP("SCRESULT",S1,C)) Q:C=""  D
  1.  ....S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,C)
  1.  ....K ^TMP("SCRESULT",S1,C)
  1.  .I CC="SORT2" D
  1.  ..S S1="" F  S S1=$O(^TMP("SCRESULT",S1)) Q:S1=""  D
  1.  ...S S2="" F  S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2=""  D
  1.  ....S C="" F  S C=$O(^TMP("SCRESULT",S1,S2,C)) Q:C=""  D
  1.  .....S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,C)
  1.  .....K ^TMP("SCRESULT",S1,S2,C)
  1.  .I CC="SORT3" D
  1.  ..S S1="" F  S S1=$O(^TMP("SCRESULT",S1)) Q:S1=""  D
  1.  ...S S2="" F  S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2=""  D
  1.  ....S S3="" F  S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3=""  D
  1.  .....S C="" F  S C=$O(^TMP("SCRESULT",S1,S2,S3,C)) Q:C=""  D
  1.  ......S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,C)
  1.  ......K ^TMP("SCRESULT",S1,S2,S3,C)
  1.  .I CC="SORT4" D
  1.  ..S S1="" F  S S1=$O(^TMP("SCRESULT",S1)) Q:S1=""  D
  1.  ...S S2="" F  S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2=""  D
  1.  ....S S3="" F  S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3=""  D
  1.  .....S S4="" F  S S4=$O(^TMP("SCRESULT",S1,S2,S3,S4)) Q:S4=""  D
  1.  ......S C="" F  S C=$O(^TMP("SCRESULT",S1,S2,S3,S4,C)) Q:C=""  D
  1.  .......S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,C)
  1.  .......K ^TMP("SCRESULT",S1,S2,S3,S4,C)
  1.  .I CC="SORT5" D
  1.  ..S S1="" F  S S1=$O(^TMP("SCRESULT",S1)) Q:S1=""  D
  1.  ...S S2="" F  S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2=""  D
  1.  ....S S3="" F  S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3=""  D
  1.  .....S S4="" F  S S4=$O(^TMP("SCRESULT",S1,S2,S3,S4)) Q:S4=""  D
  1.  ......S S5="" F  S S5=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5)) Q:S5=""  D
  1.  .......S C="" F  S C=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,C)) Q:C=""  D
  1.  ........S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,C)
  1.  ........K ^TMP("SCRESULT",S1,S2,S3,S4,S5,C)
  1.  .I CC="SORT6" D
  1.  ..S S1="" F  S S1=$O(^TMP("SCRESULT",S1)) Q:S1=""  D
  1.  ...S S2="" F  S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2=""  D
  1.  ....S S3="" F  S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3=""  D
  1.  .....S S4="" F  S S4=$O(^TMP("SCRESULT",S1,S2,S3,S4)) Q:S4=""  D
  1.  ......S S5="" F  S S5=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5)) Q:S5=""  D
  1.  .......S S6="" F  S S6=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6)) Q:S6=""  D
  1.  ........S C="" F  S C=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C)) Q:C=""  D
  1.  .........S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C)
  1.  .........K ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,C)
  1.  .I CC="SORT7" D
  1.  ..S S1="" F  S S1=$O(^TMP("SCRESULT",S1)) Q:S1=""  D
  1.  ...S S2="" F  S S2=$O(^TMP("SCRESULT",S1,S2)) Q:S2=""  D
  1.  ....S S3="" F  S S3=$O(^TMP("SCRESULT",S1,S2,S3)) Q:S3=""  D
  1.  .....S S4="" F  S S4=$O(^TMP("SCRESULT",S1,S2,S3,S4)) Q:S4=""  D
  1.  ......S S5="" F  S S5=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5)) Q:S5=""  D
  1.  .......S S6="" F  S S6=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6)) Q:S6=""  D
  1.  ........S S7="" F  S S7=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7)) Q:S7=""  D
  1.  .........S C="" F  S C=$O(^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C)) Q:C=""  D
  1.  ..........S CT=CT+1 S ^TMP("SCRESULT",CT)=^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C)
  1.  ..........K ^TMP("SCRESULT",S1,S2,S3,S4,S5,S6,S7,C)
  1.  Q
  1. EXIT ;
  1.  K STAT,TN,TPN,IEN,INST,INSTN,UNDATE,UNREA,TEAMPN,SSN,SSNN,S1,S2,S3,S4,S5,S6,S7,S8
  1.  K TEAM,TEAMN,TEAMP,PROVN,PROV,BDATE,EDATE,PAT,INAME,HOLD,NUM,NU,CC,C,CT,XX,ST
  1.  K TN2,TPN2,UNDATE2,DATE2,EFFD,ERROR,SORT,SN,PDATE,POS,PREC,JJ,J,INUM,NN,P1,P2,P3
  1.  K ^TMP("SCARRAY")
  1.  Q