FSCRPCGS ;SLC/STAFF-NOIS RPC Site Profile ;1/13/98 15:47
;;1.1;NOIS;;Sep 06, 1998
;
SITE(SITE) ; from FSCRPCG
N AZERO,CNT,ELEVEN,FOUR,LINE,NAME,NUM,ONE,ONETHREE,SITENUM,SZERO,TWOONE,TWOFOUR,VALUE,VVER,ZERO
S SITENUM=+$$STSITE^FSCRPCOC(SITE)
S CNT=0
S ZERO=$G(^NTS(2050,SITENUM,0)),ONE=$G(^(1)),FOUR=$G(^(4)),ELEVEN=$G(^(11)),ONETHREE=$G(^(13)),TWOONE=$G(^(21)),TWOFOUR=$G(^(24))
I '$L(ZERO) Q
D SET("------------------------------------------------------------------------------",.CNT)
S LINE=" SITE PROFILE REPORT "_$P(ZERO,U)
S VALUE=$$FMTE^XLFDT($$NOW^XLFDT)
S LINE=$$SETSTR^VALM1(VALUE,LINE,55,$L(VALUE))
D SET(LINE,.CNT)
D SET("------------------------------------------------------------------------------",.CNT)
D SET("FACILITY INFORMATION:",.CNT)
D SET("=====================",.CNT)
S LINE="NAME: "_$P(ZERO,U)
S LINE=$$SETSTR^VALM1("FACILITY NUMBER: ",LINE,45,20)_SITENUM
D SET(LINE,.CNT)
S LINE="ADDRESS1: "_$P(ONE,U)
S LINE=$$SETSTR^VALM1("SUPPORTING ISC: ",LINE,45,20)_$$VALUE^FSCGET($P(ZERO,U,3),2050,2)
D SET(LINE,.CNT)
S LINE="ADDRESS2: "_$P(ONE,U,2)
S LINE=$$SETSTR^VALM1("NEW REGION: ",LINE,45,20)_$P(ZERO,U,8)
D SET(LINE,.CNT)
S LINE="CITY: "_$P(ONE,U,3)
D SET(LINE,.CNT)
S LINE="STATE: "_$$VALUE^FSCGET($P(ONE,U,4),2050,7)
S LINE=$$SETSTR^VALM1("FTS TELEPHONE NO: ",LINE,45,20)_$P(ONE,U,6)
D SET(LINE,.CNT)
S LINE="ZIP CODE: "_$P(ONE,U,5)
S LINE=$$SETSTR^VALM1("COMM. TELEPHONE NO: ",LINE,45,20)_$P(ONE,U,7)
D SET(LINE,.CNT)
D SET("",.CNT)
S LINE="FAX LOCATIONS: FAX FTS FAX COMMERCIAL"
D SET(LINE,.CNT)
S LINE=" ------- --------------"
D SET(LINE,.CNT)
S NUM=0 F S NUM=$O(^NTS(2050,SITENUM,19,NUM)) Q:NUM<1 S VALUE=$G(^(NUM,0)) I $L(VALUE) D
.S LINE=" "_$P(VALUE,U)
.S LINE=$$SETSTR^VALM1($P(VALUE,U,2),LINE,30,15)_$P(VALUE,U,3)
.D SET(LINE,.CNT)
D SET("",.CNT)
D SET("VAMC STAFF:",.CNT)
D SET("===========",.CNT)
S LINE="DIRECTOR: "_$P(FOUR,U)
S LINE=$$SETSTR^VALM1($P(FOUR,U,2),LINE,55,20)
D SET(LINE,.CNT)
S LINE="ASSOCIATE DIRECTOR: "_$P(FOUR,U,3)
S LINE=$$SETSTR^VALM1($P(FOUR,U,4),LINE,55,20)
D SET(LINE,.CNT)
S LINE="ASSISTANT DIRECTOR: "_$P(FOUR,U,9)
S LINE=$$SETSTR^VALM1($P(FOUR,U,10),LINE,55,20)
D SET(LINE,.CNT)
S LINE="CHIEF OF STAFF: "_$P(FOUR,U,5)
S LINE=$$SETSTR^VALM1($P(FOUR,U,6),LINE,55,20)
D SET(LINE,.CNT)
S LINE="IRM SERVICE CHIEF: "_$P(TWOONE,U)
S LINE=$$SETSTR^VALM1($P(TWOONE,U,2),LINE,55,20)
D SET(LINE,.CNT)
S LINE="ASST IRM CHIEF: "_$P(TWOFOUR,U)
S LINE=$$SETSTR^VALM1($P(TWOFOUR,U,2),LINE,55,20)
D SET(LINE,.CNT)
S LINE="SITE MANAGER: "_$P(FOUR,U,7)
S LINE=$$SETSTR^VALM1($P(FOUR,U,8),LINE,55,20)
D SET(LINE,.CNT)
S LINE="ADP SECURITY OFFICER: "_$P(ONETHREE,U,5)
S LINE=$$SETSTR^VALM1($P(ONETHREE,U,6),LINE,55,20)
D SET(LINE,.CNT)
D SET("",.CNT)
S LINE="RANK(1994):"_$P(ZERO,U,7)_" COMPLEX LEVEL(1994): "_$P(TWOONE,U,6)_" DHCP SIZING(1994): "_$P(TWOFOUR,U,5)
D SET(LINE,.CNT)
D SET("",.CNT)
S LINE="APPLICATIONS: Date Last Updated: "_$$FMTE^XLFDT($P(ZERO,U,5))
D SET(LINE,.CNT)
D SET("=============",.CNT)
D SET(" CUR V'ED PACK",.CNT)
D SET(" APPLICATION COORDINATOR PHONE # VER VER # INST.",.CNT)
D SET("------------- ----------- ------- ----- ---- -------",.CNT)
D SET("",.CNT)
S NAME="" F S NAME=$O(^DIC(120102,"B",NAME)) Q:NAME="" S NUM=+$O(^(NAME,0)) I NUM D
.S VVER=$P($G(^DIC(120102,NUM,0)),U,2)
.S LINE=$E(NAME,1,13)
.S AZERO=$G(^NTS(2050,SITENUM,8,NUM,0))
.S LINE=$$SETSTR^VALM1($P(AZERO,U,2),LINE,17,20)
.S LINE=$$SETSTR^VALM1($P(AZERO,U,3),LINE,34,15)
.S LINE=$$SETSTR^VALM1($P(AZERO,U,7),LINE,48,8)
.S LINE=$$SETSTR^VALM1(VVER,LINE,55,8)
.I $L($P(AZERO,U,8)) S LINE=$$SETSTR^VALM1($E($P(AZERO,U,8),4,5)_"/"_$E($P(AZERO,U,8),2,3),LINE,63,8)
.D SET(LINE,.CNT)
D SET(" *Includes testing and partial package implementation",.CNT)
D SET(" based on availability of capacity.",.CNT)
D SET("",.CNT)
D SET("SYSTEMS SOFTWARE: Version",.CNT)
D SET("=================",.CNT)
S NUM=0 F S NUM=$O(^NTS(2050,SITENUM,20,NUM)) Q:NUM<1 S SZERO=$G(^(NUM,0)) I $L(SZERO) D
.S LINE=$$VALUE^FSCGET($P(SZERO,U),2050.013,.01)
.S LINE=$$SETSTR^VALM1($P(SZERO,U,2),LINE,35,10)
.D SET(LINE,.CNT)
D SET("",.CNT)
D SET("DHCP APPLICATION STATISTICS:",.CNT)
D SET("============================",.CNT)
S LINE="TOTAL PATIENTS REGISTERED: "_$G(^NTS(2050,SITENUM,"WLDG"))
S LINE=$$SETSTR^VALM1("TOTAL CLINICS: ",LINE,37,15)_$G(^NTS(2050,SITENUM,"WLCL"))
D SET(LINE,.CNT)
S LINE="TOTAL PRESCRIPTIONS: "_$G(^NTS(2050,SITENUM,"WLPS"))
S LINE=$$SETSTR^VALM1("INTERFACED LAB INSTRUMENTS: ",LINE,37,28)_$P(ELEVEN,U)
D SET(LINE,.CNT)
Q
;
SET(LINE,CNT) ;
S CNT=CNT+1
S ^TMP("FSCRPC",$J,"OUTPUT",CNT)=LINE
Q
;
TEST ;
N NUM,SITE
S SITE=100
D SITE(SITE)
S NUM=0 F S NUM=$O(^TMP("FSCRPC",$J,"OUTPUT",NUM)) Q:NUM<1 W !,^(NUM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFSCRPCGS 5176 printed Dec 13, 2024@02:19:28 Page 2
FSCRPCGS ;SLC/STAFF-NOIS RPC Site Profile ;1/13/98 15:47
+1 ;;1.1;NOIS;;Sep 06, 1998
+2 ;
SITE(SITE) ; from FSCRPCG
+1 NEW AZERO,CNT,ELEVEN,FOUR,LINE,NAME,NUM,ONE,ONETHREE,SITENUM,SZERO,TWOONE,TWOFOUR,VALUE,VVER,ZERO
+2 SET SITENUM=+$$STSITE^FSCRPCOC(SITE)
+3 SET CNT=0
+4 SET ZERO=$GET(^NTS(2050,SITENUM,0))
SET ONE=$GET(^(1))
SET FOUR=$GET(^(4))
SET ELEVEN=$GET(^(11))
SET ONETHREE=$GET(^(13))
SET TWOONE=$GET(^(21))
SET TWOFOUR=$GET(^(24))
+5 IF '$LENGTH(ZERO)
QUIT
+6 DO SET("------------------------------------------------------------------------------",.CNT)
+7 SET LINE=" SITE PROFILE REPORT "_$PIECE(ZERO,U)
+8 SET VALUE=$$FMTE^XLFDT($$NOW^XLFDT)
+9 SET LINE=$$SETSTR^VALM1(VALUE,LINE,55,$LENGTH(VALUE))
+10 DO SET(LINE,.CNT)
+11 DO SET("------------------------------------------------------------------------------",.CNT)
+12 DO SET("FACILITY INFORMATION:",.CNT)
+13 DO SET("=====================",.CNT)
+14 SET LINE="NAME: "_$PIECE(ZERO,U)
+15 SET LINE=$$SETSTR^VALM1("FACILITY NUMBER: ",LINE,45,20)_SITENUM
+16 DO SET(LINE,.CNT)
+17 SET LINE="ADDRESS1: "_$PIECE(ONE,U)
+18 SET LINE=$$SETSTR^VALM1("SUPPORTING ISC: ",LINE,45,20)_$$VALUE^FSCGET($PIECE(ZERO,U,3),2050,2)
+19 DO SET(LINE,.CNT)
+20 SET LINE="ADDRESS2: "_$PIECE(ONE,U,2)
+21 SET LINE=$$SETSTR^VALM1("NEW REGION: ",LINE,45,20)_$PIECE(ZERO,U,8)
+22 DO SET(LINE,.CNT)
+23 SET LINE="CITY: "_$PIECE(ONE,U,3)
+24 DO SET(LINE,.CNT)
+25 SET LINE="STATE: "_$$VALUE^FSCGET($PIECE(ONE,U,4),2050,7)
+26 SET LINE=$$SETSTR^VALM1("FTS TELEPHONE NO: ",LINE,45,20)_$PIECE(ONE,U,6)
+27 DO SET(LINE,.CNT)
+28 SET LINE="ZIP CODE: "_$PIECE(ONE,U,5)
+29 SET LINE=$$SETSTR^VALM1("COMM. TELEPHONE NO: ",LINE,45,20)_$PIECE(ONE,U,7)
+30 DO SET(LINE,.CNT)
+31 DO SET("",.CNT)
+32 SET LINE="FAX LOCATIONS: FAX FTS FAX COMMERCIAL"
+33 DO SET(LINE,.CNT)
+34 SET LINE=" ------- --------------"
+35 DO SET(LINE,.CNT)
+36 SET NUM=0
FOR
SET NUM=$ORDER(^NTS(2050,SITENUM,19,NUM))
if NUM<1
QUIT
SET VALUE=$GET(^(NUM,0))
IF $LENGTH(VALUE)
Begin DoDot:1
+37 SET LINE=" "_$PIECE(VALUE,U)
+38 SET LINE=$$SETSTR^VALM1($PIECE(VALUE,U,2),LINE,30,15)_$PIECE(VALUE,U,3)
+39 DO SET(LINE,.CNT)
End DoDot:1
+40 DO SET("",.CNT)
+41 DO SET("VAMC STAFF:",.CNT)
+42 DO SET("===========",.CNT)
+43 SET LINE="DIRECTOR: "_$PIECE(FOUR,U)
+44 SET LINE=$$SETSTR^VALM1($PIECE(FOUR,U,2),LINE,55,20)
+45 DO SET(LINE,.CNT)
+46 SET LINE="ASSOCIATE DIRECTOR: "_$PIECE(FOUR,U,3)
+47 SET LINE=$$SETSTR^VALM1($PIECE(FOUR,U,4),LINE,55,20)
+48 DO SET(LINE,.CNT)
+49 SET LINE="ASSISTANT DIRECTOR: "_$PIECE(FOUR,U,9)
+50 SET LINE=$$SETSTR^VALM1($PIECE(FOUR,U,10),LINE,55,20)
+51 DO SET(LINE,.CNT)
+52 SET LINE="CHIEF OF STAFF: "_$PIECE(FOUR,U,5)
+53 SET LINE=$$SETSTR^VALM1($PIECE(FOUR,U,6),LINE,55,20)
+54 DO SET(LINE,.CNT)
+55 SET LINE="IRM SERVICE CHIEF: "_$PIECE(TWOONE,U)
+56 SET LINE=$$SETSTR^VALM1($PIECE(TWOONE,U,2),LINE,55,20)
+57 DO SET(LINE,.CNT)
+58 SET LINE="ASST IRM CHIEF: "_$PIECE(TWOFOUR,U)
+59 SET LINE=$$SETSTR^VALM1($PIECE(TWOFOUR,U,2),LINE,55,20)
+60 DO SET(LINE,.CNT)
+61 SET LINE="SITE MANAGER: "_$PIECE(FOUR,U,7)
+62 SET LINE=$$SETSTR^VALM1($PIECE(FOUR,U,8),LINE,55,20)
+63 DO SET(LINE,.CNT)
+64 SET LINE="ADP SECURITY OFFICER: "_$PIECE(ONETHREE,U,5)
+65 SET LINE=$$SETSTR^VALM1($PIECE(ONETHREE,U,6),LINE,55,20)
+66 DO SET(LINE,.CNT)
+67 DO SET("",.CNT)
+68 SET LINE="RANK(1994):"_$PIECE(ZERO,U,7)_" COMPLEX LEVEL(1994): "_$PIECE(TWOONE,U,6)_" DHCP SIZING(1994): "_$PIECE(TWOFOUR,U,5)
+69 DO SET(LINE,.CNT)
+70 DO SET("",.CNT)
+71 SET LINE="APPLICATIONS: Date Last Updated: "_$$FMTE^XLFDT($PIECE(ZERO,U,5))
+72 DO SET(LINE,.CNT)
+73 DO SET("=============",.CNT)
+74 DO SET(" CUR V'ED PACK",.CNT)
+75 DO SET(" APPLICATION COORDINATOR PHONE # VER VER # INST.",.CNT)
+76 DO SET("------------- ----------- ------- ----- ---- -------",.CNT)
+77 DO SET("",.CNT)
+78 SET NAME=""
FOR
SET NAME=$ORDER(^DIC(120102,"B",NAME))
if NAME=""
QUIT
SET NUM=+$ORDER(^(NAME,0))
IF NUM
Begin DoDot:1
+79 SET VVER=$PIECE($GET(^DIC(120102,NUM,0)),U,2)
+80 SET LINE=$EXTRACT(NAME,1,13)
+81 SET AZERO=$GET(^NTS(2050,SITENUM,8,NUM,0))
+82 SET LINE=$$SETSTR^VALM1($PIECE(AZERO,U,2),LINE,17,20)
+83 SET LINE=$$SETSTR^VALM1($PIECE(AZERO,U,3),LINE,34,15)
+84 SET LINE=$$SETSTR^VALM1($PIECE(AZERO,U,7),LINE,48,8)
+85 SET LINE=$$SETSTR^VALM1(VVER,LINE,55,8)
+86 IF $LENGTH($PIECE(AZERO,U,8))
SET LINE=$$SETSTR^VALM1($EXTRACT($PIECE(AZERO,U,8),4,5)_"/"_$EXTRACT($PIECE(AZERO,U,8),2,3),LINE,63,8)
+87 DO SET(LINE,.CNT)
End DoDot:1
+88 DO SET(" *Includes testing and partial package implementation",.CNT)
+89 DO SET(" based on availability of capacity.",.CNT)
+90 DO SET("",.CNT)
+91 DO SET("SYSTEMS SOFTWARE: Version",.CNT)
+92 DO SET("=================",.CNT)
+93 SET NUM=0
FOR
SET NUM=$ORDER(^NTS(2050,SITENUM,20,NUM))
if NUM<1
QUIT
SET SZERO=$GET(^(NUM,0))
IF $LENGTH(SZERO)
Begin DoDot:1
+94 SET LINE=$$VALUE^FSCGET($PIECE(SZERO,U),2050.013,.01)
+95 SET LINE=$$SETSTR^VALM1($PIECE(SZERO,U,2),LINE,35,10)
+96 DO SET(LINE,.CNT)
End DoDot:1
+97 DO SET("",.CNT)
+98 DO SET("DHCP APPLICATION STATISTICS:",.CNT)
+99 DO SET("============================",.CNT)
+100 SET LINE="TOTAL PATIENTS REGISTERED: "_$GET(^NTS(2050,SITENUM,"WLDG"))
+101 SET LINE=$$SETSTR^VALM1("TOTAL CLINICS: ",LINE,37,15)_$GET(^NTS(2050,SITENUM,"WLCL"))
+102 DO SET(LINE,.CNT)
+103 SET LINE="TOTAL PRESCRIPTIONS: "_$GET(^NTS(2050,SITENUM,"WLPS"))
+104 SET LINE=$$SETSTR^VALM1("INTERFACED LAB INSTRUMENTS: ",LINE,37,28)_$PIECE(ELEVEN,U)
+105 DO SET(LINE,.CNT)
+106 QUIT
+107 ;
SET(LINE,CNT) ;
+1 SET CNT=CNT+1
+2 SET ^TMP("FSCRPC",$JOB,"OUTPUT",CNT)=LINE
+3 QUIT
+4 ;
TEST ;
+1 NEW NUM,SITE
+2 SET SITE=100
+3 DO SITE(SITE)
+4 SET NUM=0
FOR
SET NUM=$ORDER(^TMP("FSCRPC",$JOB,"OUTPUT",NUM))
if NUM<1
QUIT
WRITE !,^(NUM)
+5 QUIT
