PSDNMKY ;DOIFO/CMS - CSM Security Key Print ;18 Dec 02
;;3.0; CONTROLLED SUBSTANCES ;*41*;13 Feb 97
;Reference to ^XUSEC( supported by IA #1095
Q
;
ST ;CS Monitoring OPTION ENTRY
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,POP,X,Y,ZTIO,ZTSK,ZTRTN,ZTDESC,%,%ZIS
W !!,?5,"This report lists current holders of the"
W !,?5,"PSJ RPHARM and/or PSDMGR security keys.",!!
S DIR("A")="Okay to Continue",DIR("B")="No",DIR(0)="Y" D ^DIR
I Y'=1 W " <No report>",! G END
;
K IO("Q") S %ZIS="MQ" D ^%ZIS I POP W " <No device selected.>" G END
I $D(IO("Q")) D
.S ZTRTN="DQ^PSDNMKY",ZTDESC="CS Monitoring - PSDNMKY"
.D ^%ZTLOAD W !!?5,"TASK #",$G(ZTSK)," QUEUED!",!
I '$D(IO("Q")) U IO D DQ
K IOP,IO("Q")
END Q
;
;
HD ;Report heading
N PSDH,X,Y,%
W @IOF,$$CJ^XLFSTR("CS Monitoring - Security Key Report",IOM)
S PSDH="SECURITY KEY: "_$S(PSDK="BOTH":"PSDMGR & PSJ RPHARM",1:PSDK)
W !,$$CJ^XLFSTR(PSDH,IOM)
W !,"Station: ",$G(PSDIV),?20,"Report Run Date: "
S PSDPG=PSDPG+1
D NOW^%DTC W $$FMTE^XLFDT(%),?65,"PAGE: ",PSDPG
W !,$$REPEAT^XLFSTR("=",IOM)
QUIT
;
DQ ;Report Run
N D0,DA,DIC,DIQ,DR
N PSDIV,PSDK,PSDN,PSDO,PSDOUT,PSDPG,PSDS,PSDT,PSDTI,PSDX,PSDY,X,Y,%
K ^TMP("PSDNMKY",$J)
I IOST?1"C-".E W !!,?10,"Compiling report, please wait ..."
S PSDX=0
F S PSDX=$O(^XUSEC("PSDMGR",PSDX)) Q:'PSDX D
. S PSDN=$G(^VA(200,PSDX,0)) I PSDN']"" Q
. S DA=PSDX,DR=".01;8;9.2;29",DIQ="PSDO",DIQ(0)="E",DIC="^VA(200,"
. K PSDO D EN^DIQ1
. S PSDN=$G(PSDO(200,PSDX,.01,"E"))
. S PSDN=$S(PSDN]"":PSDN,1:"NO NAME (ien="_+PSDX_")")
. S PSDTI=$G(PSDO(200,PSDX,8,"E"))
. S PSDTI=$S(PSDTI]"":PSDTI,1:"UNKNOWN")
. S PSDT=$G(PSDO(200,PSDX,9.2,"E"))
. S PSDS=$G(PSDO(200,PSDX,29,"E"))
. S PSDS=$S(PSDS]"":PSDS,1:"UNKNOWN")
. I $D(^XUSEC("PSJ RPHARM",PSDX)) D Q
. . S ^TMP("PSDNMKY",$J,"BOTH",PSDS,$P(PSDN,U,1),PSDX)=PSDTI_U_PSDT
. S ^TMP("PSDNMKY",$J,"PSDMGR",PSDS,$P(PSDN,U,1),PSDX)=PSDTI_U_PSDT
;
S PSDX=0
F S PSDX=$O(^XUSEC("PSJ RPHARM",PSDX)) Q:'PSDX D
. S PSDN=$G(^VA(200,PSDX,0)) I PSDN']"" Q
. S DA=PSDX,DR=".01;8;9.2;29",DIQ="PSDO",DIQ(0)="E",DIC="^VA(200,"
. K PSDO D EN^DIQ1
. S PSDN=$G(PSDO(200,PSDX,.01,"E"))
. S PSDN=$S(PSDN]"":PSDN,1:"NO NAME (ien="_+PSDX_")")
. S PSDTI=$G(PSDO(200,PSDX,8,"E"))
. S PSDTI=$S(PSDTI]"":PSDTI,1:"UNKNOWN")
. S PSDT=$G(PSDO(200,PSDX,9.2,"E"))
. S PSDS=$G(PSDO(200,PSDX,29,"E"))
. S PSDS=$S(PSDS]"":PSDS,1:"UNKNOWN")
. I $D(^XUSEC("PSDMGR",PSDX)) D Q
. . S ^TMP("PSDNMKY",$J,"BOTH",PSDS,$P(PSDN,U,1),PSDX)=PSDTI_U_PSDT
. S ^TMP("PSDNMKY",$J,"PSJ RPHARM",PSDS,$P(PSDN,U,1),PSDX)=PSDTI_U_PSDT
;
;Report print
S PSDPG=0,PSDOUT=0,PSDIV=+$$SITE^VASITE
I '$D(^TMP("PSDNMKY",$J)) S PSDK="BOTH" D HD,PHD W !!,?10,"<<<< NO DATA FOUND >>>>",! G DQQ
S PSDK=""
F S PSDK=$O(^TMP("PSDNMKY",$J,PSDK)) Q:(PSDK="")!(PSDOUT) D
. S PSDPG=0 D HD,PHD
. S PSDS=""
. F S PSDS=$O(^TMP("PSDNMKY",$J,PSDK,PSDS)) Q:(PSDS="")!(PSDOUT) D
. . I ($Y+3)>IOSL D PAGE Q:PSDOUT D HD,PHD
. . W !!,"SERVICE/SECTION: ",PSDS
. . S PSDN=""
. . F S PSDN=$O(^TMP("PSDNMKY",$J,PSDK,PSDS,PSDN)) Q:(PSDN="")!(PSDOUT) D
. . . S PSDX=0
. . . F S PSDX=$O(^TMP("PSDNMKY",$J,PSDK,PSDS,PSDN,PSDX)) Q:('PSDX)!(PSDOUT) D
. . . . S PSDY=$G(^TMP("PSDNMKY",$J,PSDK,PSDS,PSDN,PSDX))
. . . . I ($Y+3)>IOSL D PAGE Q:PSDOUT D HD,PHD
. . . . W !,?3,PSDN,?35,$P(PSDY,U,1),?65,$P(PSDY,U,2)
. I '$G(PSDOUT),$O(^TMP("PSDNMKY",$J,PSDK))]"" D PAGE
;
DQQ K ^TMP("PSDNMKY",$J) D ^%ZISC Q
;
PHD W !,?3,"Name",?35,"Title",?64,"Termination Date"
W !,$$REPEAT^XLFSTR("_",IOM)
Q
PAGE ;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
I IOST?1"C-".E S DIR(0)="E" D ^DIR W !
I ($D(DTOUT))!($D(DIRUT)) S PSDOUT=1 Q:$G(PSDOUT)=1
Q
;
EOR ;PSDNMKY - CSM Security Key Print; 18 DEC 02
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDNMKY 3809 printed Sep 23, 2025@19:22:55 Page 2
PSDNMKY ;DOIFO/CMS - CSM Security Key Print ;18 Dec 02
+1 ;;3.0; CONTROLLED SUBSTANCES ;*41*;13 Feb 97
+2 ;Reference to ^XUSEC( supported by IA #1095
+3 QUIT
+4 ;
ST ;CS Monitoring OPTION ENTRY
+1 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,POP,X,Y,ZTIO,ZTSK,ZTRTN,ZTDESC,%,%ZIS
+2 WRITE !!,?5,"This report lists current holders of the"
+3 WRITE !,?5,"PSJ RPHARM and/or PSDMGR security keys.",!!
+4 SET DIR("A")="Okay to Continue"
SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
+5 IF Y'=1
WRITE " <No report>",!
GOTO END
+6 ;
+7 KILL IO("Q")
SET %ZIS="MQ"
DO ^%ZIS
IF POP
WRITE " <No device selected.>"
GOTO END
+8 IF $DATA(IO("Q"))
Begin DoDot:1
+9 SET ZTRTN="DQ^PSDNMKY"
SET ZTDESC="CS Monitoring - PSDNMKY"
+10 DO ^%ZTLOAD
WRITE !!?5,"TASK #",$GET(ZTSK)," QUEUED!",!
End DoDot:1
+11 IF '$DATA(IO("Q"))
USE IO
DO DQ
+12 KILL IOP,IO("Q")
END QUIT
+1 ;
+2 ;
HD ;Report heading
+1 NEW PSDH,X,Y,%
+2 WRITE @IOF,$$CJ^XLFSTR("CS Monitoring - Security Key Report",IOM)
+3 SET PSDH="SECURITY KEY: "_$SELECT(PSDK="BOTH":"PSDMGR & PSJ RPHARM",1:PSDK)
+4 WRITE !,$$CJ^XLFSTR(PSDH,IOM)
+5 WRITE !,"Station: ",$GET(PSDIV),?20,"Report Run Date: "
+6 SET PSDPG=PSDPG+1
+7 DO NOW^%DTC
WRITE $$FMTE^XLFDT(%),?65,"PAGE: ",PSDPG
+8 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+9 QUIT
+10 ;
DQ ;Report Run
+1 NEW D0,DA,DIC,DIQ,DR
+2 NEW PSDIV,PSDK,PSDN,PSDO,PSDOUT,PSDPG,PSDS,PSDT,PSDTI,PSDX,PSDY,X,Y,%
+3 KILL ^TMP("PSDNMKY",$JOB)
+4 IF IOST?1"C-".E
WRITE !!,?10,"Compiling report, please wait ..."
+5 SET PSDX=0
+6 FOR
SET PSDX=$ORDER(^XUSEC("PSDMGR",PSDX))
if 'PSDX
QUIT
Begin DoDot:1
+7 SET PSDN=$GET(^VA(200,PSDX,0))
IF PSDN']""
QUIT
+8 SET DA=PSDX
SET DR=".01;8;9.2;29"
SET DIQ="PSDO"
SET DIQ(0)="E"
SET DIC="^VA(200,"
+9 KILL PSDO
DO EN^DIQ1
+10 SET PSDN=$GET(PSDO(200,PSDX,.01,"E"))
+11 SET PSDN=$SELECT(PSDN]"":PSDN,1:"NO NAME (ien="_+PSDX_")")
+12 SET PSDTI=$GET(PSDO(200,PSDX,8,"E"))
+13 SET PSDTI=$SELECT(PSDTI]"":PSDTI,1:"UNKNOWN")
+14 SET PSDT=$GET(PSDO(200,PSDX,9.2,"E"))
+15 SET PSDS=$GET(PSDO(200,PSDX,29,"E"))
+16 SET PSDS=$SELECT(PSDS]"":PSDS,1:"UNKNOWN")
+17 IF $DATA(^XUSEC("PSJ RPHARM",PSDX))
Begin DoDot:2
+18 SET ^TMP("PSDNMKY",$JOB,"BOTH",PSDS,$PIECE(PSDN,U,1),PSDX)=PSDTI_U_PSDT
End DoDot:2
QUIT
+19 SET ^TMP("PSDNMKY",$JOB,"PSDMGR",PSDS,$PIECE(PSDN,U,1),PSDX)=PSDTI_U_PSDT
End DoDot:1
+20 ;
+21 SET PSDX=0
+22 FOR
SET PSDX=$ORDER(^XUSEC("PSJ RPHARM",PSDX))
if 'PSDX
QUIT
Begin DoDot:1
+23 SET PSDN=$GET(^VA(200,PSDX,0))
IF PSDN']""
QUIT
+24 SET DA=PSDX
SET DR=".01;8;9.2;29"
SET DIQ="PSDO"
SET DIQ(0)="E"
SET DIC="^VA(200,"
+25 KILL PSDO
DO EN^DIQ1
+26 SET PSDN=$GET(PSDO(200,PSDX,.01,"E"))
+27 SET PSDN=$SELECT(PSDN]"":PSDN,1:"NO NAME (ien="_+PSDX_")")
+28 SET PSDTI=$GET(PSDO(200,PSDX,8,"E"))
+29 SET PSDTI=$SELECT(PSDTI]"":PSDTI,1:"UNKNOWN")
+30 SET PSDT=$GET(PSDO(200,PSDX,9.2,"E"))
+31 SET PSDS=$GET(PSDO(200,PSDX,29,"E"))
+32 SET PSDS=$SELECT(PSDS]"":PSDS,1:"UNKNOWN")
+33 IF $DATA(^XUSEC("PSDMGR",PSDX))
Begin DoDot:2
+34 SET ^TMP("PSDNMKY",$JOB,"BOTH",PSDS,$PIECE(PSDN,U,1),PSDX)=PSDTI_U_PSDT
End DoDot:2
QUIT
+35 SET ^TMP("PSDNMKY",$JOB,"PSJ RPHARM",PSDS,$PIECE(PSDN,U,1),PSDX)=PSDTI_U_PSDT
End DoDot:1
+36 ;
+37 ;Report print
+38 SET PSDPG=0
SET PSDOUT=0
SET PSDIV=+$$SITE^VASITE
+39 IF '$DATA(^TMP("PSDNMKY",$JOB))
SET PSDK="BOTH"
DO HD
DO PHD
WRITE !!,?10,"<<<< NO DATA FOUND >>>>",!
GOTO DQQ
+40 SET PSDK=""
+41 FOR
SET PSDK=$ORDER(^TMP("PSDNMKY",$JOB,PSDK))
if (PSDK="")!(PSDOUT)
QUIT
Begin DoDot:1
+42 SET PSDPG=0
DO HD
DO PHD
+43 SET PSDS=""
+44 FOR
SET PSDS=$ORDER(^TMP("PSDNMKY",$JOB,PSDK,PSDS))
if (PSDS="")!(PSDOUT)
QUIT
Begin DoDot:2
+45 IF ($Y+3)>IOSL
DO PAGE
if PSDOUT
QUIT
DO HD
DO PHD
+46 WRITE !!,"SERVICE/SECTION: ",PSDS
+47 SET PSDN=""
+48 FOR
SET PSDN=$ORDER(^TMP("PSDNMKY",$JOB,PSDK,PSDS,PSDN))
if (PSDN="")!(PSDOUT)
QUIT
Begin DoDot:3
+49 SET PSDX=0
+50 FOR
SET PSDX=$ORDER(^TMP("PSDNMKY",$JOB,PSDK,PSDS,PSDN,PSDX))
if ('PSDX)!(PSDOUT)
QUIT
Begin DoDot:4
+51 SET PSDY=$GET(^TMP("PSDNMKY",$JOB,PSDK,PSDS,PSDN,PSDX))
+52 IF ($Y+3)>IOSL
DO PAGE
if PSDOUT
QUIT
DO HD
DO PHD
+53 WRITE !,?3,PSDN,?35,$PIECE(PSDY,U,1),?65,$PIECE(PSDY,U,2)
End DoDot:4
End DoDot:3
End DoDot:2
+54 IF '$GET(PSDOUT)
IF $ORDER(^TMP("PSDNMKY",$JOB,PSDK))]""
DO PAGE
End DoDot:1
+55 ;
DQQ KILL ^TMP("PSDNMKY",$JOB)
DO ^%ZISC
QUIT
+1 ;
PHD WRITE !,?3,"Name",?35,"Title",?64,"Termination Date"
+1 WRITE !,$$REPEAT^XLFSTR("_",IOM)
+2 QUIT
PAGE ;
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 IF IOST?1"C-".E
SET DIR(0)="E"
DO ^DIR
WRITE !
+3 IF ($DATA(DTOUT))!($DATA(DIRUT))
SET PSDOUT=1
if $GET(PSDOUT)=1
QUIT
+4 QUIT
+5 ;
EOR ;PSDNMKY - CSM Security Key Print; 18 DEC 02
