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