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

SCDXSUP1.m

Go to the documentation of this file.
  1. SCDXSUP1 ;RENO/KEITH ALB/SCK - Supervisory Options for Ambulatory Care Reporting; 2/26/97
  1. ;;5.3;Scheduling;**104,127,132**;Aug 13,1993
  1. Q
  1. ;
  1. APPTY ; Edit Appointment type for Add/Edit
  1. N DIC,DTOUT,DUTOUT,SCDFN,SCI,SCG,SCOUT,SCDT,DIR,DIRUT
  1. ;
  1. S SCBD=$$ASKDT("Beginning") G:SCBD<0 APPQ
  1. APP1 S SCED=$$ASKDT("Ending") G:SCED<0 APPQ
  1. I SCED<SCBD D G APP1
  1. . W !!,"Ending date cannot be earlier than the beginning date!"
  1. ;
  1. ASK S DIC="^DPT(",DIC(0)="AEMQ"
  1. D ^DIC K DIC
  1. G:$D(DTOUT)!$D(DUOUT) APPQ
  1. G:Y'>0 EXIT
  1. S SCDFN=+Y
  1. ;
  1. I '$D(^SCE("C",SCDFN)) D G ASK
  1. . W !!,"This patient has no outpatient encounters on file!",!!
  1. ;
  1. K ^TMP("SCEA",$J)
  1. S (SCI,SCG,SCOUT)=0
  1. ;
  1. D WAIT^DICD
  1. W !
  1. S SCDT=SCED+.999999
  1. F S SCDT=$O(^SCE("ADFN",SCDFN,SCDT),-1) Q:'SCDT!(SCOUT)!(SCDT<SCBD) D
  1. . S SCI=SCI+1
  1. . S SCDT=$P(SCDT,".") ; -- reset to stop processing date
  1. . S ^TMP("SCEA",$J,1,SCI)=SCDT
  1. . W !,SCI,?5,$$FMTE^XLFDT(SCDT,"1P")
  1. . I SCI#5=0 D GET(SCI)
  1. ;
  1. I SCI'>0 D G ASK
  1. . W !!,"No encounters on file for this patient during this date range.",!
  1. ;
  1. I SCI#5'=0 D GET(SCI)
  1. D:SCG SCED
  1. G ASK
  1. APPQ ;
  1. K DIE,DR,DTOUT,DUOUT
  1. Q
  1. ;
  1. EXIT ;
  1. Q
  1. ;
  1. GET(SCN) ; Select appointment from list
  1. N DIR,DIRUT,DUOUT,DTOUT
  1. K DIR
  1. W !
  1. S DIR(0)="NO^1:"_SCN,DIR("A")="Select number, or ENTER to continue"
  1. S DIR("?",1)="Select entry to edit appointment type for from the list above"
  1. S DIR("?")="Press ENTER to continue."
  1. D ^DIR K DIR
  1. I $D(DUOUT)!($D(DTOUT)) S SCOUT=1 Q
  1. I $D(DIRUT) Q
  1. I Y S SCG=Y,SCOUT=1
  1. Q
  1. ;
  1. SCED ; Select stop code
  1. N DIC,DIR,DIE,DR,SCK,DA,SCY,SCLINE,SUCCESS,SCDT,SCDATE,SCE,SCE0,SDLOG
  1. ;
  1. S SCDATE=^TMP("SCEA",$J,1,SCG)
  1. ;
  1. S SCDT=SCDATE
  1. F S SCDT=$O(^SCE("ADFN",SCDFN,SCDT)) Q:'SCDT!($P(SCDT,".")'=SCDATE) D
  1. . S SCE=0
  1. . F S SCE=$O(^SCE("ADFN",SCDFN,SCDT,SCE)) Q:'SCE D
  1. . . S SCE0=$G(^SCE(SCE,0))
  1. . . I $P($G(^SC(+$P(SCE0,U,4),"OOS")),U),$G(^SCE(SCE,"CG")) D SET
  1. ;
  1. I '$D(SCK) D Q
  1. . W !!,"No occasion-of-service add/edits for this patient/date.",!
  1. ;
  1. I $D(SCK) D
  1. . W !!,"Appt. DT",?24,"Location",?60,"Appt. Type"
  1. . S SCLINE="",$P(SCLINE,"-",(IOM-1))="" W !,SCLINE
  1. ;
  1. S SCE=0
  1. F S SCE=$O(SCK(SCE)) Q:'SCE D W !!
  1. . S Y=$P(SCK(SCE),U) X ^DD("DD")
  1. . W !,Y,?24,$E($P(SCK(SCE),U,2),1,30),?60,$E($P(SCK(SCE),U,3),1,18)
  1. ;
  1. K DIC
  1. S DIC="^SD(409.1,",DIC(0)="AEMQ"
  1. S DIC("A")="Select new appointment type for these encounters: "
  1. S DIC("B")="COMPUTER GENERATED"
  1. D ^DIC K DIC
  1. Q:$D(DTOUT)!$D(DUOUT)
  1. Q:Y<1
  1. S SCY=$P(Y,U)
  1. ;
  1. K DIR
  1. S DIR(0)="Y",DIR("A")="OK to change to "_$P(Y,U,2),DIR("B")="YES"
  1. D ^DIR K DIR
  1. Q:$D(DTOUT)!$D(DUOUT)
  1. Q:'Y
  1. ;
  1. K DIE,DR
  1. S DA=0
  1. F S DA=$O(SCK(DA)) Q:'DA D
  1. . K SUCCESS
  1. . L +^SCE(DA):5 S SUCCESS=$S(($T):1,1:0)
  1. . I SUCCESS D
  1. .. S DIE="^SCE(",DR=".1////^S X=SCY"
  1. .. D ^DIE K DIE
  1. .. D LOGDATA^SDAPIAP(DA,.SDLOG)
  1. . E D
  1. .. W !,"Outpatient Encounter entry: "_DA_" for "_$P($G(^DPT(SCDFN,0)),U)_" is in use, cannot edit."
  1. . L -^SCE(DA)
  1. ;
  1. W !,"Done."
  1. Q
  1. ;
  1. SET ;
  1. N SCDT,SCCL,SCTY
  1. ;
  1. S SCDT=+SCE0
  1. S SCCL=$P(^SC($P(SCE0,U,4),0),U)
  1. S SCTY=$P($G(^SD(409.1,+$P(SCE0,U,10),0)),U)
  1. S:SCDT SCK(SCE)=SCDT_U_SCCL_U_SCTY
  1. Q
  1. ;
  1. ASKDT(TXT) ; Enter beginning date for searching outpatient encounter file
  1. S DIR(0)="DA^2961001:NOW:EXP",DIR("A")="Enter "_TXT_" date for search: "
  1. S DIR("?")="^D HELP^%DTC"
  1. S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT())
  1. D ^DIR K DIR
  1. S:$D(DIRUT) Y=-1
  1. K DIRUT
  1. Q Y