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

ASDCP.m

Go to the documentation of this file.
  1. ASDCP ; IHS/ADC/PDW/ENM - CLINIC PROFILE PRINT ; [ 03/25/1999 11:48 AM ]
  1. ;;5.0;IHS SCHEDULING;;MAR 25, 1999
  1. ;
  1. PRT ;EP; called by ^SDCP for IHS version of clinic profile
  1. S ASDSTOP="" I $Y>(IOSL-12) D NEWPG
  1. W !,"CLINIC: ",$E(NAME,1,30),?40,"TELEPHONE: ",$$PHONE
  1. ;
  1. S SDNO="" I $D(^SC(SC,"I")) D
  1. . S SDRE=+$P(^SC(SC,"I"),U,2),SDIN=+^("I")
  1. . I SDRE'=SDIN D:SDIN'>DT&(SDRE=0!(SDRE>DT)) INACT^SDCP
  1. ;
  1. W !,"ABBREV: ",ABBR I $D(^SC("AIHSPC",SC)) W " - A PRINCIPAL CLINIC"
  1. W ?40,"LOCATION: ",LOC
  1. W !,"FACILITY: ",$$SITE
  1. I 'SDNO D
  1. . S Y=STDAT D:STDAT'="UNKNOWN" DTS^SDUTL
  1. . W ?40,"START DATE: ",$S(STDAT="UNKNOWN":"UNKNOWN",1:Y)
  1. I $D(^SC("AIHSPC",SC)) D PCLIST Q
  1. W !,"CLINIC CODE: ",STCD W:PC]"" ?40,"PRINCIPAL CLINIC: ",$E(PC,1,21)
  1. I 'SDNO D
  1. . W !,"DAYS CLINIC MEETS: ",DAYS,?40,"HOUR DISPLAY BEGINS: "
  1. . W $S(HCDB="":"8 AM",HCDB<13:HCDB_" AM",1:HCDB-12_" PM")
  1. W !,"APPOINTMENT LENGTH: ",LOP,?40,"VARIABLE: ",ALV
  1. W !,"MAX OVERBOOKS/DAY: ",ODM
  1. W:$D(SDMX) ?40,"MAX # DAYS FOR FUTURE BOOKING: ",SDMX
  1. W !,"SCHEDULE ON HOLIDAYS: ",$$HOLIDAY
  1. W ?40,"NON-COUNT CLINIC: ",$S(SDCNT="Y":"YES",1:"NO")
  1. W !,"INCLUDE ON FILE ROOM LIST: ",$$FRL,?40,"PRINT HS: ",$$HS
  1. W !,"PRINT MED PROFILE: ",$$MEDP,?40,"PRINT ADDRESS UPDATE: ",$$AIU
  1. I $O(^SC(SC,"SI",0)) D SPECIAL
  1. W !!,"PROHIBIT ACCESS TO CLINIC: ",SDPR
  1. I SDPR="YES" D PRVUSR
  1. I 'SDNO,$D(SDIN),SDIN>DT,SDRE'=SDIN D
  1. . W !,?4,"**** Clinic will be inactive ",$S(SDRE:"from ",1:"as of ")
  1. . S Y=SDIN D DTS^SDUTL W Y S Y=SDRE D:Y DTS^SDUTL
  1. . W $S(SDRE:" to "_Y,1:"")," ****" K SDIN,SDRE
  1. I 'SDSC D
  1. . W !?4,"** INVALID OR INACTIVE STOP CODE ASSIGNED TO THIS CLINIC **"
  1. W !!
  1. Q
  1. ;
  1. NEWPG ; -- SUBRTN to handle
  1. I IOST'["C-" D TOF S ASDSTOP="" Q
  1. K DIR S DIR(0)="E" D ^DIR S ASDSTOP=X
  1. I ASDSTOP'=U D TOF
  1. Q
  1. ;
  1. TOF W @IOF,?22,"CLINIC PROFILES AS OF: ",PDATE,! Q
  1. ;
  1. PCLIST ; -- SUBRTN to list all clinics grouped under principal clinic
  1. NEW ASDX
  1. I $Y>(IOSL-3) D NEWPG Q:ASDSTOP=U
  1. W !!,"CLINICS GROUPED UNDER THIS PRINCIPAL CLINIC:"
  1. S ASDX=0 F S ASDX=$O(^SC("AIHSPC",SC,ASDX)) Q:ASDX="" Q:ASDSTOP=U D
  1. . Q:'$$ACTV^ASDUT(ASDX)
  1. . I $X>40 D:$Y>(IOSL-3) NEWPG Q:ASDSTOP=U W !?3,$P(^SC(ASDX,0),U) Q
  1. . W ?40,$P(^SC(ASDX,0),U)
  1. W !!
  1. Q
  1. ;
  1. SPECIAL ; -- SUBRTN to print out special instructions
  1. NEW ASDX
  1. I $Y>(IOSL-3) D NEWPG Q:ASDSTOP=U
  1. W !!,"SPECIAL INSTRUCTIONS:"
  1. S ASDX=0 F S ASDX=$O(^SC(SC,"SI",ASDX)) Q:'ASDX Q:ASDSTOP=U D
  1. . I $Y>(IOSL-3) D NEWPG Q:ASDSTOP=U
  1. . W !,^SC(SC,"SI",ASDX,0)
  1. Q
  1. ;
  1. PRVUSR ; -- SUBRTN to list priv. users
  1. NEW ASDX
  1. W " - Access restricted to:"
  1. S ASDX=0 F S ASDX=$O(^SC(SC,"SDPRIV",ASDX)) Q:'ASDX Q:ASDSTOP=U D
  1. . I $X>40 D Q
  1. .. I $Y>(IOSL-3) D NEWPG Q:ASDSTOP=U
  1. .. W !?3,$$VAL^XBDIQ1(200,+^SC(SC,"SDPRIV",ASDX,0),.01)
  1. . W ?40,$$VAL^XBDIQ1(200,+^SC(SC,"SDPRIV",ASDX,0),.01)
  1. Q
  1. ;
  1. PHONE() ; -- returns phone #
  1. Q $S($D(^SC(SC,99)):^SC(SC,99),1:"")
  1. ;
  1. SITE() ; -- returns institution
  1. Q $$VAL^XBDIQ1(44,SC,3)
  1. ;
  1. HOLIDAY() ; -- returns whether clinic meets on holidays
  1. NEW X S X=$$VAL^XBDIQ1(44,SC,1918.5)
  1. Q $S(X]"":X,1:"NO")
  1. ;
  1. FRL() ; -- returns answer to include on file room list
  1. NEW X S X=$$VAL^XBDIQ1(44,SC,2502.5)
  1. Q $S(X]"":X,SDCNT="Y":"NO",1:"YES")
  1. ;
  1. HS() ; -- returns if user wants health summaries printed
  1. NEW X S X=$$VAL^XBDIQ1(44,SC,9999999.1)
  1. Q $S(X="NO":X,1:"YES - "_$$VAL^XBDIQ1(44,SC,9999999.2))
  1. ;
  1. MEDP() ; -- returns whether med profiles should print
  1. NEW X S X=$$VAL^XBDIQ1(44,SC,9999999.3)
  1. Q $S(X]"":X,1:"NO")
  1. ;
  1. AIU() ; -- returns whether address updates should print
  1. NEW X S X=$$VAL^XBDIQ1(44,SC,9999999.4)
  1. Q $S(X]"":X,1:"NO")