- 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")