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

DGQPT1.m

Go to the documentation of this file. 
  1. DGQPT1 ; SLC/MKB - Change Patient Selection List ;6/5/01 12:36pm
  1.  ;;5.3;Registration;**447**;Aug 13, 1993
  1.  ;
  1.  ; SLC/PKS - 5/2000: Modified to deal with "Combinations."
  1.  ;
  1. CONTEXT() ; -- Returns current patient list context
  1.  Q $P($G(^TMP("DG",$J,"PATIENTS",0)),U,3)
  1.  ;
  1. WARD ; -- new ward list
  1.  N X,Y,DIC
  1.  D FULL^VALM1 S VALMBCK="R"
  1.  S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"W"),U,2)  ;added by CLA 8/4/97
  1.  S DIC("S")="N D0,X S D0=+Y D WIN^DGPMDDCF I 'X" ; inactive?
  1.  S DIC=42,DIC(0)="AEQM" D ^DIC Q:Y'>0  S $P(DGY,";",1,2)="W;"_+Y
  1.  Q
  1.  ;
  1. CLINIC ; -- new clinic list
  1.  N X,Y,Z,DIC,BEG,END,BEG1,END1
  1.  D FULL^VALM1 S VALMBCK="R"
  1.  S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"C"),U,2)  ;added by CLA 8/4/97
  1.  S DIC=44,DIC(0)="AEQM",DIC("A")="Select CLINIC: "
  1.  S DIC("S")="I $P(^(0),U,3)=""C"",$$ACTLOC^SDWU(+Y)"
  1.  D ^DIC Q:Y'>0  S (BEG1,END1)=""
  1.  S Z=$$DATE($P(ORY,";",3),1) Q:Z="^"  S BEG=$P(Z,U),BEG1=$P(Z,U,2)
  1.  I BEG1 S Z=$$DATE($P(DGY,";",4),0) Q:Z="^"  S END=$P(Z,U),END1=$P(Z,U,2)
  1.  I 'BEG1!'END1 Q
  1.  I BEG1,END1,END1<BEG1 S X=END,END=BEG,BEG=X ; switch
  1.  S $P(DGY,";",1,4)="C;"_+Y_";"_BEG_";"_END
  1.  Q
  1.  ;
  1. DATE(DEFLT,START) ; -- new start/stop date
  1.  N X,Y,DIR,%DT
  1.  S DIR(0)="FAO^1:20",DIR("A")=$S($G(START):"START",1:"STOP")_" DATE: "
  1.  S:$L($G(DEFLT)) DIR("B")=DEFLT
  1.  S DIR("?")="Enter the "_$S($G(START):"earliest",1:"latest")_" date for appointments to this clinic for which you wish to see the patients listed; indicate the date relative to TODAY, i.e. T+1 for tomorrow or T-2W for 2 weeks ago."
  1. D1 D ^DIR S:$D(DTOUT) X="^"
  1.  I "^"'[X S %DT="X" D ^%DT S:Y>0 X=X_U_Y I Y'>0 W $C(7),!,DIR("?"),! G D1
  1.  Q X
  1.  ;
  1. PROV ; -- new provider list
  1.  N X,Y,DIC
  1.  D FULL^VALM1 S VALMBCK="R"
  1.  S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"P"),U,2)  ;added by CLA 8/4/97
  1.  S DIC=200,DIC(0)="AEQ",DIC("A")="Select PROVIDER: ",D="AK.PROVIDER"
  1.  D IX^DIC Q:Y'>0  S $P(DGY,";",1,2)="P;"_+Y
  1.  Q
  1.  ;
  1. TEAM ; -- new team list
  1.  N X,Y,DIC
  1.  D FULL^VALM1 S VALMBCK="R"
  1.  S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"T"),U,2)  ;added by CLA 8/4/97
  1.  S DIC=100.21,DIC(0)="AEQM",DIC("A")="Select TEAM: "
  1.  D ^DIC Q:Y'>0  S $P(DGY,";",1,2)="T;"_+Y
  1.  Q
  1.  ;
  1. SPEC ; -- new treating specialty list
  1.  N X,Y,DIC
  1.  D FULL^VALM1 S VALMBCK="R"
  1.  S DIC("B")=$P($$LISTSRC^DGQPTQ11(DUZ,"S"),U,2)  ;added by CLA 8/4/97
  1.  S DIC=45.7,DIC(0)="AEQM",DIC("S")="I $$ACTIVE^DGACT(45.7,Y,DT)"
  1.  D ^DIC Q:Y'>0  S $P(DGY,";",1,2)="S;"_+Y
  1.  Q
  1.  ;
  1. SORT ; -- new sort order
  1.  N X,Y,DIR
  1.  S X=($E(DGY)="C"),Y=$P(DGY,";",5)
  1.  S DIR(0)="SAM^A:Alphabetic;"_$S(X:"P:Date of Appointment;",1:"R:Room-Bed;")
  1.  S DIR("A")="(A)lphabetic or "_$S(X:"Date of A(p)pointment? ",1:"(R)oom-Bed? ")
  1.  S DIR("B")=$S(Y="R"&'X:"Room-Bed",Y="P"&X:"Date of Appointment",1:"Alphabetic")
  1.  ; Next 4 lines added by PKS to deal with "Combinations:"
  1.  I $E(ORY)="M" D 
  1.  . S DIR(0)="SAM^A:Alphabetic;P:Appointment;S:Source"
  1.  . S DIR("A")="(A)lphabetic or Date of A(p)pointment or (S)ource  "
  1.  . S DIR("B")="Alphabetic"
  1.  S DIR("?")="Enter the attribute you wish the list to sort by"
  1.  D ^DIR S:$D(DTOUT) Y="^" Q:Y="^"
  1.  S $P(DGY,";",5)=Y
  1.  Q
  1.  ;
  1. SAVE ; -- Save current list definition as default
  1.  N X,LIST,IFN,BEG,END,PARAM S VALMBCK=""
  1.  Q:'$$OK  W !!,"Saving patient list definition ... "
  1.  S LIST=$$CONTEXT,X=$E(LIST)
  1.  ; Next line modified by PKS:
  1.  S PARAM="DGLP DEFAULT "_$S(X="T":"TEAM",X="P":"PROVIDER",X="S":"SPECIALTY",X="W":"WARD",X="C":"CLINIC ",X="M":"MULTIPLE",1:"^") I PARAM["^" W !,"ERROR" H 2 Q
  1.  ;added by CLA 12/12/96:
  1.  N DGSRV S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
  1.  ;
  1.  D EN^XPAR("USR","DGLP DEFAULT LIST SOURCE",1,X)
  1.  S IFN="`"_+$P(LIST,";",2)
  1.  I X'="C" D EN^XPAR("USR",PARAM,1,IFN)
  1.  I X="C" D  ; add clinic for each day of week & start & stop dates
  1.  . N CPARAM
  1.  . S CPARAM=PARAM_"MONDAY" D EN^XPAR("USR",CPARAM,1,IFN)
  1.  . S CPARAM=PARAM_"TUESDAY" D EN^XPAR("USR",CPARAM,1,IFN)
  1.  . S CPARAM=PARAM_"WEDNESDAY" D EN^XPAR("USR",CPARAM,1,IFN)
  1.  . S CPARAM=PARAM_"THURSDAY" D EN^XPAR("USR",CPARAM,1,IFN)
  1.  . S CPARAM=PARAM_"FRIDAY" D EN^XPAR("USR",CPARAM,1,IFN)
  1.  . S CPARAM=PARAM_"SATURDAY" D EN^XPAR("USR",CPARAM,1,IFN)
  1.  . S CPARAM=PARAM_"SUNDAY" D EN^XPAR("USR",CPARAM,1,IFN)
  1.  . S BEG=$P(LIST,";",3),END=$P(LIST,";",4)
  1.  . D EN^XPAR("USR","DGLP DEFAULT CLINIC START DATE",1,BEG)
  1.  . D EN^XPAR("USR","DGLP DEFAULT CLINIC STOP DATE",1,END)
  1.  I $L($P(LIST,";",5)) D EN^XPAR("USR","DGLP DEFAULT LIST ORDER",1,$P(LIST,";",5))
  1.  W "done." H 1 S VALMBCK=""
  1.  Q
  1.  ;
  1. OK() ; -- Current definition ok?
  1.  N X,Y,DIR,LIST,PTR,SORT,BEG,END W !!,"Current List: "
  1.  S LIST=$$CONTEXT,PTR=+$P(LIST,";",2),BEG=$P(LIST,";",3),END=$P(LIST,";",4),SORT=$P(LIST,";",5)
  1.  I $E(LIST)="W" W "Ward "_$P($G(^DIC(42,+PTR,0)),U)
  1.  I $E(LIST)="C" W "Clinic "_$P($G(^SC(+PTR,0)),U)
  1.  I $E(LIST)="P" W "Primary Provider "_$P($G(^VA(200,+PTR,0)),U)
  1.  I $E(LIST)="T" W "Team "_$P($G(^OR(100.21,+PTR,0)),U)
  1.  I $E(LIST)="S" W "Specialty "_$P($G(^DIC(45.7,+PTR,0)),U)
  1.  ; Next line added by PKS:
  1.  I $E(LIST)="M" W "Combination"
  1.  I $L(SORT) W ", sorted by "_$S(SORT="P":"Appointment Date",SORT="R":"Room-Bed",1:"Name")
  1.  I $E(LIST)="C",BEG W !?14,"from "_BEG_" to "_END
  1.  S DIR(0)="YA",DIR("A")="Are you sure you want to save these list parameters as your default? "
  1.  S DIR("?")="Enter YES if you wish to use these same parameters again the next time a patient list is created for you to select from, or NO to quit without saving."
  1.  W ! D ^DIR
  1.  Q +Y
  1.  ;
  1. REMOVE ; Remove current default patient list view parameter setting(s).
  1.  ; SLC/PKS - 5/2000.
  1.  ;
  1.  ; Variables used:
  1.  ;
  1.  ;    DGDUZ  = User's DUZ.
  1.  ;    DGQENT = Entity string for call to XPAR.
  1.  ;    DGQERR = Error array for call to XPAR.
  1.  ;    DGQSRC = Holds return value of call to FDEFSRC^ORQPTQ11(ORDUZ).
  1.  ;
  1.  N DGQDUZ,DGQENT,DGQERR,DGQSRC
  1.  ;
  1.  K DGQERR
  1.  S VALMBCK=""
  1.  S DGQDUZ=DUZ
  1.  Q:'$$OKR
  1.  W !!,"Removing your personal patient list definition ... "
  1.  S DGQENT=DUZ_";VA(200,"
  1.  D DEL^XPAR(DGQENT,"DGLP DEFAULT LIST SOURCE",,.ORQERR)
  1.  I ('$D(DGQERR)!(DGQERR=0)) D
  1.  .W "done."
  1.  .S DGQSRC=$$FDEFSRC^DGQPTQ11(DGQDUZ) ; Check for Service default.
  1.  .I $P(DGQSRC,U)'="" W !,"(NOTE: Service/Section default of """_$P(DGQSRC,U,3)_""" not affected.)"
  1.  .H 4
  1.  I $D(DGQERR) D
  1.  .S DGQSRC=$$FDEFSRC^DGQPTQ11(DGQDUZ) ; Check for Service default.
  1.  .I DGQERR=0 Q
  1.  .I $P(DGQERR,U,2)="Parameter instance not found" D  Q
  1.  ..W "nothing to remove."
  1.  ..I $P(DGQSRC,U)'="" W !,"(NOTE: Service/Section default of """_$P(DGQSRC,U,3)_""" not affected.)"
  1.  ..H 4
  1.  .W !,"   ERROR: "_$P(DGQERR,U,2) H 3
  1.  S VALMBCK=""
  1.  Q
  1.  ;
  1. OKR() ; -- Remove current definition?
  1.  N X,Y,DIR,LIST,PTR
  1.  S DIR(0)="YA"
  1.  S DIR("A")="Are you sure you want to remove your current list default view? "
  1.  S DIR("?")="Enter YES if you wish to remove your current default patient list view, or NO to leave the current personal setting(s)."
  1.  W ! ; For display esthetics.
  1.  D ^DIR
  1.  Q +Y
  1.  ;
  1. COMBO ; New combination list.
  1.  ; SLC/PKS - 5/2000.
  1.  ;
  1.  ; Preset VALM for return:
  1.  D FULL^VALM1 S VALMBCK="R"
  1.  ;
  1.  ; Call existing code to create/edit user's "combination" sources:
  1.  D COMB^DGLP3USR
  1.  ;
  1.  ; Write the piece in "ORY" to indicate "Combination" sources:
  1.  S $P(DGY,";",1)="M"
  1.  D REBUILD
  1.  ;
  1.  Q
  1.  ;
  1. REBUILD ; -- Ok to rebuild listing?
  1.  N DGQUIT
  1.  I $E(DGY)="C",$P(DGY,";",5)="R" D  Q:$G(DGQUIT)
  1.  . W !!,">> A Clinic list cannot be sorted by room-bed assignment!"
  1.  . W !,"   Please select a new sorting order:",!
  1.  . D SORT S:$P(DGY,";",5)="R" DGQUIT=1
  1.  ; Next section added by PKS for "Combinations:" 
  1.  I $E(DGY)="M",$P(DGY,";",5)="R" D  Q:$G(DGQUIT)
  1.  . W !!,">> A Combination list cannot be sorted by room-bed assignment!"
  1.  . W !,"   Please select a new sorting order:",!
  1.  . D SORT S:$P(DGY,";",5)="R" DGQUIT=1
  1.  I (($E(DGY)'="C")&($E(DGY)'="M")),$P(DGY,";",5)="P" D  Q:$G(DGQUIT)
  1.  . W !!,">> A "_$S($E(DGY)="W":"Ward",$E(DGY)="P":"Primary Provider",$E(DGY)="T":"Team",$E(DGY)="S":"Specialty",1:"")_" list cannot be sorted by clinic appointment date!"
  1.  . W !,"   Please select a new sorting order:",!
  1.  . D SORT S:$P(DGY,";",5)="P" DGQUIT=1
  1.  D BUILD^DGQPT(DGY)
  1.  Q