Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT
Files:
14 edited

Legend:

Unmodified
Added
Removed
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31ENV.m

    r613 r623  
    1 YS31ENV ;DALCIOFO/MJD-YS*5.01*31 PATCH ENVIRONMENT CHECK ROUTINE ;10/30/97
    2         ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
    3 EN      ; Does not prevent loading of the transport global.
    4         ;Environment check is done only during the install.
    5         QUIT:'$G(XPDENV)
    6         D CHECK
    7         ;
    8 EXIT    I $G(XPDQUIT) W !!,$$CJ^XLFSTR("Install Environment Check FAILED",80)
    9         I '$G(XPDQUIT) W !!,$$CJ^XLFSTR("Environment Check is Done...",80)
    10         K VER,RN,LN2
    11         QUIT
    12         ;
    13 CHECK   ;
    14         I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) W !,$$CJ^XLFSTR("Terminal Device is not defined",80),!! S XPDQUIT=2 Q
    15         I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) W !!,$$CJ^XLFSTR("Please Log in to set local DUZ... variables",80),! S XPDQUIT=2 Q
    16         I '$D(^VA(200,$G(DUZ),0))#2 W !,$$CJ^XLFSTR("You are not a valid user on this system",80),! S XPDQUIT=2 Q
    17         S VER=$$VERSION^XPDUTL("MENTAL HEALTH")
    18         I VER'=5.01 W !,$$CJ^XLFSTR("You must have Mental Health V 5.01 Installed",80),! S XPDQUIT=2 Q
    19         QUIT
    20         ;
    21 EOR     ;;YS*5.01*31 PATCH ENVIRONMENT CHECK ROUTINE;;
     1YS31ENV ;DALCIOFO/MJD-YS*5.01*31 PATCH ENVIRONMENT CHECK ROUTINE ;10/30/97
     2 ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
     3EN ; Does not prevent loading of the transport global.
     4 ;Environment check is done only during the install.
     5 QUIT:'$G(XPDENV)
     6 D CHECK
     7 ;
     8EXIT I $G(XPDQUIT) W !!,$$CJ^XLFSTR("Install Environment Check FAILED",80)
     9 I '$G(XPDQUIT) W !!,$$CJ^XLFSTR("Environment Check is Done...",80)
     10 K VER,RN,LN2
     11 QUIT
     12 ;
     13CHECK ;
     14 I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) W !,$$CJ^XLFSTR("Terminal Device is not defined",80),!! S XPDQUIT=2 Q
     15 I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) W !!,$$CJ^XLFSTR("Please Log in to set local DUZ... variables",80),! S XPDQUIT=2 Q
     16 I '$D(^VA(200,$G(DUZ),0))#2 W !,$$CJ^XLFSTR("You are not a valid user on this system",80),! S XPDQUIT=2 Q
     17 S VER=$$VERSION^XPDUTL("MENTAL HEALTH")
     18 I VER'=5.01 W !,$$CJ^XLFSTR("You must have Mental Health V 5.01 Installed",80),! S XPDQUIT=2 Q
     19 QUIT
     20 ;
     21EOR ;;YS*5.01*31 PATCH ENVIRONMENT CHECK ROUTINE;;
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YS31POST.m

    r613 r623  
    1 YS31POST        ;DALCIOFO/MJD-PATCH YS*5.01*31 POST RTN. ;09/23/97
    2         ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
    3         ;
    4         ; Unless the site has modified this file the zero node
    5         ; for file #601 MH INSTRUMENT should look like:
    6         ; ^YTT(601,0) = MH INSTRUMENT^601^233^88
    7         S:$P(^YTT(601,0),U,3)="225" $P(^YTT(601,0),U,3)=233
    8         S $P(^YTT(601,0),U,4)=$P(^YTT(601,0),U,4)+8
    9         ;
    10         QUIT
     1YS31POST ;DALCIOFO/MJD-PATCH YS*5.01*31 POST RTN. ;09/23/97
     2 ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
     3 ;
     4 ; Unless the site has modified this file the zero node
     5 ; for file #601 MH INSTRUMENT should look like:
     6 ; ^YTT(601,0) = MH INSTRUMENT^601^233^88
     7 S:$P(^YTT(601,0),U,3)="225" $P(^YTT(601,0),U,3)=233
     8 S $P(^YTT(601,0),U,4)=$P(^YTT(601,0),U,4)+8
     9 ;
     10 QUIT
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSERV.m

    r613 r623  
    1 YSCLSERV        ;DALOI/RLM-Clozapine data server ;24 APR 1990
    2         ;;5.01;MENTAL HEALTH;**18,22,26,47,61,69,74,90,92**;Dec 30, 1994;Build 7
    3         ; Reference to ^%ZOSF supported by IA #10096
    4         ; Reference to ^DPT supported by IA #10035
    5         ; Reference to ^DD("DD" supported by IA #10017
    6         ; Reference to ^PS(55 supported by IA #787
    7         ; Reference to ^PSDRUG supported by IA #25
    8         ; Reference to ^PSRX supported by IA #780
    9         ; Reference to ^VA(200 supported by IA #10060
    10         ; Reference to $$SITE^VASITE supported by IA #10112
    11         ; Reference to $$FMTE^XLFDT() supported by IA #10103
    12         ; Reference to ^PSDRUG supported by IA #221
    13         ; Reference to ^XMD supported by IA #10070
    14 START   ;
    15         K ^TMP($J,"YSCLDATA")
    16         S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3)
    17         S YSCLST=$P($$SITE^VASITE,"^",3)
    18         S YSCLSTN=$P($$SITE^VASITE,"^",2)
    19         ;Determine station number
    20         S X=XQSUB X ^%ZOSF("UPPERCASE") S YSCLSUB=Y
    21         S ^TMP($J,"YSCLDATA",1)=$S(YSDEBUG:"DEBUG ",1:"")_YSCLSUB_" triggered at "_YSCLST_" by "_XMFROM_" on "_XQDATE
    22         ;The first line of the message tells who requested the action and when
    23         D
    24          . S YSACTION=$S(YSCLSUB["REMOVE"!(YSCLSUB["DELETE"):"data deleted",YSCLSUB["REPORT":"report generated",YSCLSUB["REBUILD":"data verified",YSCLSUB["UPDATE":"data updated",YSCLSUB["DATESET":"date set",1:"CONT")
    25          . I YSACTION="CONT" S YSACTION=$S(YSCLSUB["DEMOG RESET":"Demographics Flag Reset",YSCLSUB["DEBUG":"Debug Mode set",YSCLSUB["AUTH":"Authorization",YSCLSUB["LOCK":"Lock",1:"Site Lock")
    26          . S ^TMP($J,"YSCLDATA",2)="No "_$S(YSDEBUG:"DEBUG ",1:"")_YSACTION_" at "_YSCLST
    27         ;The second line tells when the server is activated and no data can be
    28         ;gathered from the MailMan message.  This line gets replaced if the
    29         ;server finds something to do.
    30         S YSCLLNT=1 I YSCLSUB["REMOVE"!(YSCLSUB["DELETE") G DELETE
    31         ;If the subject contains the word REMOVE or DELETE delete those entries from the list.
    32         I YSCLSUB["REPORT" G REPORT
    33         ;If the subject contains "REPORT" send a report of the currently registered patients to the Clozapine group on Forum
    34         ;I YSCLSUB["REBUILD" G REBUILD
    35         I YSCLSUB["RESEND" G RESEND
    36         I YSCLSUB["UPDATE" G UPDATE
    37         ;I YSCLSUB["CHECKSUM" G CSUM^YSCLSRV1
    38         I YSCLSUB["DATESET" G DSET
    39         I YSCLSUB["DEBUG" G DEBUG
    40         I YSCLSUB["PATIENT" G ^YSCLSRV3
    41         I YSCLSUB["LOCKOUT" G LOCK^YSCLSRV3
    42         I YSCLSUB="DEMOG RESET" G DEMOG^YSCLSRV3
    43         I YSCLSUB["AUTHORIZE" G AUTH^YSCLSRV3
    44         I YSCLSUB="OVERRIDE" G OVRRID^YSCLSRV2
    45         I YSCLSUB="CLAPI" G CLAPI^YSCLSRV2
    46         I YSCLSUB="CL1API" G CL1API^YSCLSRV2
    47         I YSCLSUB["DISCON" G DCON^YSCLSRV2
    48         F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
    49          . ;Verify that + of site number matches local site number
    50          . I XMRG'?2U5N1","9N1","1U S YSCLER=" is in error and was not added at " D OUT Q
    51          . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q
    52          . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q
    53          . I $P(XMRG,",",3)'="B",$P(XMRG,",",3)'="W",$P(XMRG,",",3)'="M" S YSCLER=" You must specify Weekly, Biweekly, or Monthly " D OUT Q
    54          . ;Validate the format of the data in the message and report the error.
    55          . S DIC="^DPT(",DIC(0)="X",D="SSN",X=$P(XMRG,",",2) I '$D(^DPT("SSN",X)) S YSCLER=" SSN does not exist at " D OUT Q
    56          . ;Do not add data for records where the SSN sent is not in the local database
    57          . I $D(^YSCL(603.01,"B",$P(XMRG,","))) S YSCLX=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" Clozapine # is in use by "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT Q
    58          . D MIX^DIC1 S YSCLPT=+Y I Y=-1 S YSCLER=" could not be added at " D OUT Q
    59          . ;Add the data and report any errors to the Roll-Up group at Forum.
    60          . K DD S DIC="^YSCL(603.01,",X=$P(XMRG,","),DIC("DR")="1////"_YSCLPT_";2////"_$P(XMRG,",",3) K DO D FILE^DICN
    61          . S YSCLX=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" assigned to "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT
    62 EXIT    ;If all went well, report that too.
    63         S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3)
    64         S %H=$H D YMD^%DTC S XMDUN="NCCC LOGGER",XMDUZ=".5",XMSUB=$S(YSDEBUG:"DEBUG ",YSCLSUB["DEBUG":"DEBUG ",1:"")_YSCLST_" NCCC ENROLLER ("_X_%_")",XMTEXT="^TMP($J,""YSCLDATA"","
    65         K XMY S XMY("G.CLOZAPINE ROLL-UP@FORUM.VA.GOV")=""
    66         I YSDEBUG!(YSCLSUB["DEBUG") S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")=""
    67         D ^XMD
    68         ;Mail the errors and successes back to the Roll-Up group at Forum.
    69         K ^TMP($J,"YSCLDATA")
    70         K %,%DT,%H,D,DA,DD,DIC,DIE,DIK,RET,X,XMDUN,XMDUZ,XMER,XMFROM
    71         K XMREC,XMRG,XMSUB,XMTEXT,XMY,XMZ,XQDATE,XQSUB,Y,YSA,YSACTION,YSCLTYPE
    72         K YSCL28,YSCLA,YSCLAA,YSCLB,YSCLC,YSCLDA,YSCLDA1,YSCLDATA,YSCLDEA1
    73         K YSCLDFN,YSCLDM,YSCLDOC,YSCLDOM,YSCLDR,YSCLDRA,YSCLDRB,YSCLDTA,YSCLERR
    74         K YSCLDUZ,YSCLED,YSCLER,YSCLFDA,YSCLFRQ,YSCLLNT,YSCLNM,YSCLOVR,YSCLSITE
    75         K YSCLPT,YSCLRPT,YSCLSD1,YSCLSDT,YSCLSSN,YSCLST,YSCLSTN,YSCLSUB,YSCLTC
    76         K YSCLRX,YSCLSAND,YSCLWB,YSCLX,YSCLYN,YSDEBUG,YSI,YSOFF,YSPR,ZTQUEUED,ZTSK
    77         Q
    78 DELETE  ;Allow the NCCC users to delete clozapine registration at the individual sites
    79         S YSCLLNT=1 F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
    80          . I XMRG="**++**DELETEALL**++**" D DELALL Q
    81          . I '$D(^YSCL(603.01,"B",$P(XMRG,","))) S YSCLER=" "_$P(XMRG,",")_" is not registered at " D OUT Q
    82          . S YSCLDFN=$O(^DPT("SSN",$P(XMRG,",",2),"")) I YSCLDFN="" S YSCLER=" "_$P(XMRG,",")_" is not a valid SSN at " D OUT Q
    83          . I '$D(^YSCL(603.01,"C",YSCLDFN)) S YSCLER=" "_$P(XMRG,",",2)_" is not registered at " D OUT Q
    84          . S YSCLA=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) I YSCLA="" S YSCLER=" "_$P(XMRG,",")_" is not a valid entry at " D OUT Q
    85          . K ^YSCL(603.01,YSCLA),^YSCL(603.01,"B",$P(XMRG,","),YSCLA),^YSCL(603.01,"C",YSCLDFN,YSCLA)
    86          . S YSCLER=" removed at " D OUT
    87          . ;I $D(^YSCL(603.01,"C",+Y)) K ^YSCL(603.01,YSCLA),^YSCL(603.01,"B",$P(XMRG,","),YSCLA),^YSCL(603.01,"C",YSCLDFN,YSCLA) S YSCLER=" removed at " D OUT Q  ;RLM 9-29-99 ADDED QUIT
    88         G EXIT
    89 DELALL  ;Delete all patients in file 603.01
    90         S YSCLA=0 F  S YSCLA=$O(^YSCL(603.01,YSCLA)) Q:YSCLA=""  D
    91          . I YSCLA S YSCLER=$P(^YSCL(603.01,YSCLA,0),"^",1)_", "_$P(^DPT($P(^YSCL(603.01,YSCLA,0),"^",2),0),"^",9)_", ("_$P(^YSCL(603.01,YSCLA,0),"^",3)_") gdeleted at " D OUT
    92          . K ^YSCL(603.01,YSCLA)
    93         Q
    94 REPORT  ;send report of current registrations to the Clozapine group on Forum
    95         D REPORT^YSCLSRV2 G EXIT
    96 OUT     S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=XMRG_YSCLER_YSCLST Q
    97         ;Build the text for the return message here.
    98 REBUILD ;
    99         D REBUILD^YSCLSRV2 G EXIT
    100 UPDATE  ;Update record with Monthly, Weekly or Bi-weekly status
    101         F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
    102          . I XMRG'?2U5N1","9N1","1U S YSCLER=" is in error and was not added at " D OUT Q
    103          . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number format " D OUT Q
    104          . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q
    105          . I $P(XMRG,",",3)'="B",$P(XMRG,",",3)'="W",$P(XMRG,",",3)'="M" S YSCLER=" You must specify Monthly, Weekly or Biweekly " D OUT Q  ;RLM 06/15/05
    106          . S YSCLNM=$P(XMRG,","),YSCLSSN=$P(XMRG,",",2),YSCLWB=$P(XMRG,",",3)
    107          . I '$D(^YSCL(603.01,"B",YSCLNM)) S YSCLER=" does not exist at " D OUT Q
    108          . S YSCLDA=$O(^DPT("SSN",YSCLSSN,0))
    109          . I YSCLDA="" S YSCLER=" SSN does not exist at " D OUT Q
    110          . I $O(^YSCL(603.01,"B",YSCLNM,0))="" S YSCLER=" SSN not in Clozapine file " D OUT Q
    111          . I $O(^DPT("SSN",YSCLSSN,YSCLDA)) S YSCLER=" SSN has more than one owner " D OUT Q
    112          . I $O(^YSCL(603.01,"B",YSCLNM,0))'=$O(^YSCL(603.01,"C",YSCLDA,0)) S YSCLER=" SSN ("_YSCLSSN_","_$P(^DPT(YSCLDA,0),"^")_") has multiple Clozapine Numbers at " D OUT
    113          . I $O(^YSCL(603.01,"B",YSCLNM,0))=$O(^YSCL(603.01,"C",YSCLDA,0)) D
    114          . . S YSCLDA1=$O(^YSCL(603.01,"B",YSCLNM,0)) S $P(^YSCL(603.01,YSCLDA1,0),"^",3)=YSCLWB
    115          . . S YSCLER=" "_YSCLNM_" ("_$P(^DPT(YSCLDA,0),"^")_") updated to "_$S(YSCLWB="M":"Monthly",YSCLWB="W":"Weekly",YSCLWB="B":"Bi-weekly",1:"Unknown")_" at " D OUT ;06/15/05
    116         G EXIT
    117 RESEND  ;Trigger retransmission of Clozapine data
    118         X XMREC
    119         K %DT S X=XMRG,%DT="P" D ^%DT I Y=-1 S YSCLER=" is an invalid date, RESEND not triggered at " D OUT G EXIT
    120         S YSCLED=Y,(YSCLSDT,X)=Y D H^%DTC I %H#7'=5 S YSCLER=" is not a Tuesday, RESEND not triggered at " D OUT G EXIT
    121         D SERV^YSCLTST2
    122         S Y=YSCLSDT X ^DD("DD") S YSCLER=" - Resend triggered (local task #"_$G(ZTSK)_") by "_XMFROM_" for "_Y_" at " D OUT
    123         G EXIT
    124 DSET    ;Set the day of the week for the roll-up to run.
    125         X XMREC Q:XMER<0  S X=$TR(XMRG,"- ","")
    126         S YSOFF=$S(X="SUNDAY":0,X="MONDAY":1,X="TUESDAY":2,X="WEDNESDAY":3,X="THURSDAY":4,X="FRIDAY":5,X="SATURDAY":6,1:7)
    127         I YSOFF>6 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=X_" isn't a valid day of the week." G EXIT
    128         S $P(^YSCL(603.03,1,0),"^",2)=X
    129         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Run day set to "_X
    130         G EXIT
    131         Q
    132 DEBUG   ;Turn debug mode on and off.
    133         I YSCLSUB["DEBUG ON" D
    134          . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Debug Mode is "_$S(YSDEBUG:"already",1:"now")_" ON at "_YSCLSTN
    135          . S $P(^YSCL(603.03,1,0),"^",3)=1
    136         I YSCLSUB["DEBUG OFF" D
    137          . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Debug Mode is "_$S('YSDEBUG:"already",1:"now")_" OFF at "_YSCLSTN
    138          . S $P(^YSCL(603.03,1,0),"^",3)=0
    139         G EXIT
    140 ZEOR    ;YSCLSERV
     1YSCLSERV ;DALOI/RLM-Clozapine data server ;24 APR 1990
     2 ;;5.01;MENTAL HEALTH;**18,22,26,47,61,69,74,90**;Dec 30, 1994;Build 18
     3 ; Reference to ^%ZOSF supported by IA #10096
     4 ; Reference to ^DPT supported by IA #10035
     5 ; Reference to ^DD("DD" supported by IA #10017
     6 ; Reference to ^PS(55 supported by IA #787
     7 ; Reference to ^PSDRUG supported by IA #25
     8 ; Reference to ^PSRX supported by IA #780
     9 ; Reference to ^VA(200 supported by IA #10060
     10 ; Reference to $$SITE^VASITE supported by IA #10112
     11 ; Reference to $$FMTE^XLFDT() supported by IA #10103
     12 ; Reference to ^PSDRUG supported by IA #221
     13 ; Reference to ^XMD supported by IA #10070
     14START ;
     15 K ^TMP($J,"YSCLDATA")
     16 S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3)
     17 S YSCLST=$P($$SITE^VASITE,"^",3)
     18 S YSCLSTN=$P($$SITE^VASITE,"^",2)
     19 ;Determine station number
     20 S X=XQSUB X ^%ZOSF("UPPERCASE") S YSCLSUB=Y
     21 S ^TMP($J,"YSCLDATA",1)=$S(YSDEBUG:"DEBUG ",1:"")_YSCLSUB_" triggered at "_YSCLST_" by "_XMFROM_" on "_XQDATE
     22 ;The first line of the message tells who requested the action and when
     23 D
     24  . S YSACTION=$S(YSCLSUB["REMOVE"!(YSCLSUB["DELETE"):"data deleted",YSCLSUB["REPORT":"report generated",YSCLSUB["REBUILD":"data verified",YSCLSUB["UPDATE":"data updated",YSCLSUB["DATESET":"date set",1:"CONT")
     25  . I YSACTION="CONT" S YSACTION=$S(YSCLSUB["DEMOG RESET":"Demographics Flag Reset",YSCLSUB["DEBUG":"Debug Mode set",YSCLSUB["AUTH":"Authorization",YSCLSUB["LOCK":"Lock",1:"Site Lock")
     26  . S ^TMP($J,"YSCLDATA",2)="No "_$S(YSDEBUG:"DEBUG ",1:"")_YSACTION_" at "_YSCLST
     27 ;The second line tells when the server is activated and no data can be
     28 ;gathered from the MailMan message.  This line gets replaced if the
     29 ;server finds something to do.
     30 S YSCLLNT=1 I YSCLSUB["REMOVE"!(YSCLSUB["DELETE") G DELETE
     31 ;If the subject contains the word REMOVE or DELETE delete those entries from the list.
     32 I YSCLSUB["REPORT" G REPORT
     33 ;If the subject contains "REPORT" send a report of the currently registered patients to the Clozapine group on Forum
     34 ;I YSCLSUB["REBUILD" G REBUILD
     35 I YSCLSUB["RESEND" G RESEND
     36 I YSCLSUB["UPDATE" G UPDATE
     37 I YSCLSUB["CHECKSUM" G CSUM^YSCLSRV1
     38 I YSCLSUB["DATESET" G DSET
     39 I YSCLSUB["DEBUG" G DEBUG
     40 I YSCLSUB["PATIENT" G ^YSCLSRV3
     41 I YSCLSUB["LOCKOUT" G LOCK^YSCLSRV3
     42 I YSCLSUB="DEMOG RESET" G DEMOG^YSCLSRV3
     43 I YSCLSUB["AUTHORIZE" G AUTH^YSCLSRV3
     44 I YSCLSUB="OVERRIDE" G OVRRID^YSCLSRV2
     45 F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
     46  . ;Verify that + of site number matches local site number
     47  . I XMRG'?2U5N1","9N1","1U S YSCLER=" is in error and was not added at " D OUT Q
     48  . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q
     49  . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q
     50  . I $P(XMRG,",",3)'="B",$P(XMRG,",",3)'="W",$P(XMRG,",",3)'="M" S YSCLER=" You must specify Weekly, Biweekly, or Monthly " D OUT Q
     51  . ;Validate the format of the data in the message and report the error.
     52  . S DIC="^DPT(",DIC(0)="X",D="SSN",X=$P(XMRG,",",2) I '$D(^DPT("SSN",X)) S YSCLER=" SSN does not exist at " D OUT Q
     53  . ;Do not add data for records where the SSN sent is not in the local database
     54  . I $D(^YSCL(603.01,"B",$P(XMRG,","))) S YSCLX=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" Clozapine # is in use by "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT Q
     55  . D MIX^DIC1 S YSCLPT=+Y I Y=-1 S YSCLER=" could not be added at " D OUT Q
     56  . ;Add the data and report any errors to the Roll-Up group at Forum.
     57  . K DD S DIC="^YSCL(603.01,",X=$P(XMRG,","),DIC("DR")="1////"_YSCLPT_";2////"_$P(XMRG,",",3) K DO D FILE^DICN
     58  . S YSCLX=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" assigned to "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT
     59EXIT ;If all went well, report that too.
     60 S YSDEBUG=$P(^YSCL(603.03,1,0),"^",3)
     61 S %H=$H D YMD^%DTC S XMDUN="NCCC LOGGER",XMDUZ=".5",XMSUB=$S(YSDEBUG:"DEBUG ",YSCLSUB["DEBUG":"DEBUG ",1:"")_YSCLST_" NCCC ENROLLER ("_X_%_")",XMTEXT="^TMP($J,""YSCLDATA"","
     62 K XMY S XMY("G.CLOZAPINE ROLL-UP@FORUM.VA.GOV")=""
     63 I YSDEBUG!(YSCLSUB["DEBUG") S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")=""
     64 D ^XMD
     65 ;Mail the errors and successes back to the Roll-Up group at Forum.
     66 K ^TMP($J,"YSCLDATA")
     67 K %,%DT,%H,D,DA,DD,DIC,DIE,DIK,RET,X,XMDUN,XMDUZ,XMER,XMFROM
     68 K XMREC,XMRG,XMSUB,XMTEXT,XMY,XMZ,XQDATE,XQSUB,Y,YSA,YSACTION
     69 K YSCL28,YSCLA,YSCLAA,YSCLB,YSCLC,YSCLDA,YSCLDA1,YSCLDATA,YSCLDEA1
     70 K YSCLDFN,YSCLDM,YSCLDOC,YSCLDOM,YSCLDR,YSCLDRA,YSCLDRB,YSCLDTA
     71 K YSCLDUZ,YSCLED,YSCLER,YSCLFDA,YSCLFRQ,YSCLLNT,YSCLNM,YSCLOVR
     72 K YSCLPT,YSCLSD1,YSCLSDT,YSCLSSN,YSCLST,YSCLSTN,YSCLSUB,YSCLTC
     73 K YSCLWB,YSCLX,YSCLYN,YSDEBUG,YSI,YSOFF,YSPR,ZTQUEUED,ZTSK
     74 Q
     75DELETE ;Allow the NCCC users to delete clozapine registration at the individual sites
     76 S YSCLLNT=1 F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
     77  . I XMRG="**++**DELETEALL**++**" D DELALL Q
     78  . I '$D(^YSCL(603.01,"B",$P(XMRG,","))) S YSCLER=" "_$P(XMRG,",")_" is not registered at " D OUT Q
     79  . S YSCLDFN=$O(^DPT("SSN",$P(XMRG,",",2),"")) I YSCLDFN="" S YSCLER=" "_$P(XMRG,",")_" is not a valid SSN at " D OUT Q
     80  . I '$D(^YSCL(603.01,"C",YSCLDFN)) S YSCLER=" "_$P(XMRG,",",2)_" is not registered at " D OUT Q
     81  . S YSCLA=$O(^YSCL(603.01,"B",$P(XMRG,","),"")) I YSCLA="" S YSCLER=" "_$P(XMRG,",")_" is not a valid entry at " D OUT Q
     82  . K ^YSCL(603.01,YSCLA),^YSCL(603.01,"B",$P(XMRG,","),YSCLA),^YSCL(603.01,"C",YSCLDFN,YSCLA)
     83  . S YSCLER=" removed at " D OUT
     84  . ;I $D(^YSCL(603.01,"C",+Y)) K ^YSCL(603.01,YSCLA),^YSCL(603.01,"B",$P(XMRG,","),YSCLA),^YSCL(603.01,"C",YSCLDFN,YSCLA) S YSCLER=" removed at " D OUT Q  ;RLM 9-29-99 ADDED QUIT
     85 G EXIT
     86DELALL ;Delete all patients in file 603.01
     87 S YSCLA=0 F  S YSCLA=$O(^YSCL(603.01,YSCLA)) Q:YSCLA=""  D
     88  . I YSCLA S YSCLER=$P(^YSCL(603.01,YSCLA,0),"^",1)_", "_$P(^DPT($P(^YSCL(603.01,YSCLA,0),"^",2),0),"^",9)_", ("_$P(^YSCL(603.01,YSCLA,0),"^",3)_") gdeleted at " D OUT
     89  . K ^YSCL(603.01,YSCLA)
     90 Q
     91REPORT ;send report of current registrations to the Clozapine group on Forum
     92 D REPORT^YSCLSRV2 G EXIT
     93OUT S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=XMRG_YSCLER_YSCLST Q
     94 ;Build the text for the return message here.
     95REBUILD ;
     96 D REBUILD^YSCLSRV2 G EXIT
     97UPDATE ;Update record with Monthly, Weekly or Bi-weekly status
     98 F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
     99  . I XMRG'?2U5N1","9N1","1U S YSCLER=" is in error and was not added at " D OUT Q
     100  . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number format " D OUT Q
     101  . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q
     102  . I $P(XMRG,",",3)'="B",$P(XMRG,",",3)'="W",$P(XMRG,",",3)'="M" S YSCLER=" You must specify Monthly, Weekly or Biweekly " D OUT Q  ;RLM 06/15/05
     103  . S YSCLNM=$P(XMRG,","),YSCLSSN=$P(XMRG,",",2),YSCLWB=$P(XMRG,",",3)
     104  . I '$D(^YSCL(603.01,"B",YSCLNM)) S YSCLER=" does not exist at " D OUT Q
     105  . S YSCLDA=$O(^DPT("SSN",YSCLSSN,0))
     106  . I YSCLDA="" S YSCLER=" SSN does not exist at " D OUT Q
     107  . I $O(^YSCL(603.01,"B",YSCLNM,0))="" S YSCLER=" SSN not in Clozapine file " D OUT Q
     108  . I $O(^DPT("SSN",YSCLSSN,YSCLDA)) S YSCLER=" SSN has more than one owner " D OUT Q
     109  . I $O(^YSCL(603.01,"B",YSCLNM,0))'=$O(^YSCL(603.01,"C",YSCLDA,0)) S YSCLER=" SSN ("_YSCLSSN_","_$P(^DPT(YSCLDA,0),"^")_") has multiple Clozapine Numbers at " D OUT
     110  . I $O(^YSCL(603.01,"B",YSCLNM,0))=$O(^YSCL(603.01,"C",YSCLDA,0)) D
     111  . . S YSCLDA1=$O(^YSCL(603.01,"B",YSCLNM,0)) S $P(^YSCL(603.01,YSCLDA1,0),"^",3)=YSCLWB
     112  . . S YSCLER=" "_YSCLNM_" ("_$P(^DPT(YSCLDA,0),"^")_") updated to "_$S(YSCLWB="M":"Monthly",YSCLWB="W":"Weekly",YSCLWB="B":"Bi-weekly",1:"Unknown")_" at " D OUT ;06/15/05
     113 G EXIT
     114RESEND ;Trigger retransmission of Clozapine data
     115 X XMREC
     116 K %DT S X=XMRG,%DT="P" D ^%DT I Y=-1 S YSCLER=" is an invalid date, RESEND not triggered at " D OUT G EXIT
     117 S YSCLED=Y,(YSCLSDT,X)=Y D H^%DTC I %H#7'=5 S YSCLER=" is not a Tuesday, RESEND not triggered at " D OUT G EXIT
     118 D SERV^YSCLTST2
     119 S Y=YSCLSDT X ^DD("DD") S YSCLER=" - Resend triggered (local task #"_$G(ZTSK)_") by "_XMFROM_" for "_Y_" at " D OUT
     120 G EXIT
     121DSET ;Set the day of the week for the roll-up to run.
     122 X XMREC Q:XMER<0  S X=$TR(XMRG,"- ","")
     123 S YSOFF=$S(X="SUNDAY":0,X="MONDAY":1,X="TUESDAY":2,X="WEDNESDAY":3,X="THURSDAY":4,X="FRIDAY":5,X="SATURDAY":6,1:7)
     124 I YSOFF>6 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=X_" isn't a valid day of the week." G EXIT
     125 S $P(^YSCL(603.03,1,0),"^",2)=X
     126 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Run day set to "_X
     127 G EXIT
     128 Q
     129DEBUG ;Turn debug mode on and off.
     130 I YSCLSUB["DEBUG ON" D
     131  . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Debug Mode is "_$S(YSDEBUG:"already",1:"now")_" ON at "_YSCLSTN
     132  . S $P(^YSCL(603.03,1,0),"^",3)=1
     133 I YSCLSUB["DEBUG OFF" D
     134  . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Debug Mode is "_$S('YSDEBUG:"already",1:"now")_" OFF at "_YSCLSTN
     135  . S $P(^YSCL(603.03,1,0),"^",3)=0
     136 G EXIT
     137ZEOR ;YSCLSERV
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV2.m

    r613 r623  
    1 YSCLSRV2        ;DALOI/RLM-Clozapine data server ;APR 24,1990@15:26
    2         ;;5.01;MENTAL HEALTH;**69,90,92**;Dec 30, 1994;Build 7
    3         ; Reference to ^%ZOSF supported by IA #10096
    4         ; Reference to ^DPT supported by IA #10035
    5         ; Reference to ^DD("DD" supported by IA #10017
    6         ; Reference to ^PS(55 supported by IA #787
    7         ; Reference to ^PSDRUG supported by IA #25
    8         ; Reference to ^PSRX supported by IA #780
    9         ; Reference to ^VA(200 supported by IA #10060
    10         ; Reference to $$SITE^VASITE supported by IA #10112
    11         ; Reference to $$FMTE^XLFDT() supported by IA #10103
    12         ; Reference to ^PSDRUG supported by IA #221
    13         ; Reference to ^LAB(60 supported by IA #333
    14         ;
    15 REPORT  ;send report of current registrations to the Clozapine group on Forum
    16         S XMRG="",YSCLA=0 F  S YSCLA=$O(^YSCL(603.01,YSCLA)) Q:'YSCLA  S YSCLDTA=$G(^YSCL(603.01,YSCLA,0)) D
    17          . I YSCLDTA="" S YSCLER="Clozapine Patient List damaged at " D OUT Q
    18          . S YSCLWB=$P(YSCLDTA,"^",3),YSCLWB=$S(YSCLWB="M":"Monthly",YSCLWB="W":"Weekly",YSCLWB="B":"Bi-weekly",1:"Unknown")
    19          . S YSCLER=$P(YSCLDTA,"^")_" is assigned to "_$P($G(^DPT($P(YSCLDTA,"^",2),0)),"^")_" ("_$P($G(^DPT($P(YSCLDTA,"^",2),0)),"^",9)_") "_YSCLWB_" at " D OUT
    20         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="=========="
    21         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="  Linked Tests:"
    22         S YSCLA=0 F  S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA  D
    23          . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=$P(^LAB(60,$P(^YSCL(603.04,1,1,YSCLA,0),"^",1),0),"^")
    24          . S YSCLTYPE=$P(^YSCL(603.04,1,1,YSCLA,0),"^",2),YSCLRPT=$P(^YSCL(603.04,1,1,YSCLA,0),"^",3)
    25          . S YSCLTA="  reports  "_$S(YSCLTYPE="W":"WHITE BLOOD COUNT",YSCLTYPE="A":"ABSOLUTE NEUTROPHIL COUNT",YSCLTYPE="N":"NEUTROPHIL PERCENT",YSCLTYPE="S":"SEGS %",YSCLTYPE="B":"BANDS %",YSCLTYPE="T":"BANDS A",YSCLTYPE="C":"SEGS A")
    26          . S ^TMP($J,"YSCLDATA",YSCLLNT)=^TMP($J,"YSCLDATA",YSCLLNT)_YSCLTA_"  "_$S(YSCLRPT:"K/units",1:"units")
    27         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="=========="
    28         ;D OPTION^%ZTLOAD("YSCL WEEKLY TRANSMISSION","LIST") D
    29         ; . S ZTSK="" F  S ZTSK=$O(LIST(ZTSK)) Q:ZTSK=""  D
    30         ; . . D STAT^%ZTLOAD S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Local Task # "_ZTSK_" is "_$S('ZTSK(0):" not ",1:"")_"defined with a status of "_ZTSK(2)
    31         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="              Run day is: "_$P(^YSCL(603.03,1,0),"^",2)
    32         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="           Debug Mode is: "_$S($P(^YSCL(603.03,1,0),"^",3):"On.",1:"Off.")
    33         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Last Run Date (start) is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",4))
    34         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Last Run Date (stop) is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",5))
    35         S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Last Demographic date is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",6))
    36         Q
    37 OUT     S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=XMRG_YSCLER_YSCLST Q
    38         ;Build the text for the return message here.
    39 REBUILD ;
    40         S XMRG="",(YSCLA,YSCLLNT)=1 F  S YSCLA=$O(^PS(55,"ASAND1",YSCLA)) W:'$D(ZTQUEUED) "." Q:YSCLA=""  D
    41          . S YSCLB=$O(^PS(55,"ASAND1",YSCLA,"")) I YSCLB="" S YSCLER=" record is in error (1) at " D OUT Q
    42          . I '$D(^PS(55,YSCLB,0)) S YSCLER=" record is in error (2) at " D OUT Q
    43          . S YSCLB=$P(^PS(55,YSCLB,0),"^") I YSCLB="" S YSCLER=" record is in error (3) at " D OUT Q
    44          . I '$D(^PS(55,YSCLB,"SAND")) S YSCLER=" record is in error (4) at " D OUT Q
    45          . S DIC="^DPT(",DIC(0)="X",D="SSN",(YSCLSSN,X)=$P(^DPT(YSCLB,0),"^",9)
    46          . I $D(^YSCL(603.01,"B",YSCLA)) S YSCLX=$O(^YSCL(603.01,"B",YSCLA,"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" Clozapine # "_YSCLA_" is in use by "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT Q
    47          . D MIX^DIC1 S YSCLPT=+Y I Y=-1 S YSCLER=" could not be added at " D OUT Q
    48          . K DD S DIC="^YSCL(603.01,",X=YSCLA,DIC("DR")="1////"_YSCLPT K DO D FILE^DICN
    49          . S YSCLX=$O(^YSCL(603.01,"B",YSCLA,"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=","_YSCLSSN_" assigned to "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT
    50         Q
    51 OVRRID  ;Update record with Monthly, Weekly or Bi-weekly status
    52         F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
    53          . I XMRG'?2U5N1","9N1",".E S YSCLER=" is in error and was not added at " D OUT Q
    54          . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number format " D OUT Q
    55          . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q
    56          . K %DT S X=$P(XMRG,",",3),%DT="F" D ^%DT I Y=-1 S YSCLER=" is an invalid date, over-ride authorization not filed at " D OUT Q
    57          . S YSCLOVR=Y
    58          . S YSCLNM=$P(XMRG,","),YSCLSSN=$P(XMRG,",",2),YSCLWB=$P(XMRG,",",3)
    59          . I '$D(^YSCL(603.01,"B",YSCLNM)) S YSCLER=" does not exist at " D OUT Q
    60          . S YSCLDA=$O(^DPT("SSN",YSCLSSN,0))
    61          . I YSCLDA="" S YSCLER=" SSN does not exist at " D OUT Q
    62          . I $O(^YSCL(603.01,"B",YSCLNM,0))="" S YSCLER=" SSN not in Clozapine file " D OUT Q
    63          . I $O(^DPT("SSN",YSCLSSN,YSCLDA)) S YSCLER=" SSN has more than one owner " D OUT Q
    64          . I $O(^YSCL(603.01,"B",YSCLNM,0))'=$O(^YSCL(603.01,"C",YSCLDA,0)) S YSCLER=" SSN ("_YSCLSSN_","_$P(^DPT(YSCLDA,0),"^")_") has multiple Clozapine Numbers at " D OUT
    65          . I $O(^YSCL(603.01,"B",YSCLNM,0))=$O(^YSCL(603.01,"C",YSCLDA,0)) D
    66          . . S YSCLDA1=$O(^YSCL(603.01,"B",YSCLNM,0)) S $P(^YSCL(603.01,YSCLDA1,0),"^",4)=YSCLOVR
    67          . . S Y=YSCLOVR D DD^%DT S YSCLER=" "_YSCLNM_" ("_$P(^DPT(YSCLDA,0),"^")_") authorized for over-ride on "_Y_" at " D OUT
    68         G EXIT^YSCLSERV
    69         ;
    70 CLAPI   ;
    71         F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
    72          . ;Verify that a valid Clozapine number is listed
    73          . S YSCLDA=$E(XMRG,1,7)
    74          . I YSCLDA'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q
    75          . S YSCLDA=$O(^YSCL(603.01,"B",YSCLDA,"")),YSCLDA=$P($G(^YSCL(603.01,YSCLDA,0)),"^",2)
    76          . I 'YSCLDA S YSCLER=" is not in the local database." D OUT Q
    77          . S YSCLNM=$$CL^YSCLTST2(YSCLDA) S YSCLER=" = "_YSCLNM_" at " D OUT
    78          . Q
    79          G EXIT^YSCLSERV
    80 CL1API  ;
    81         F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
    82          . ;Verify that a valid Clozapine number is listed
    83          . S YSA=$P(XMRG,"^",1),YSCLDA=$P(XMRG,"^",2)
    84          . I YSCLDA'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q
    85          . S YSCLDA=$O(^YSCL(603.01,"B",YSCLDA,"")),YSCLDA=$P($G(^YSCL(603.01,YSCLDA,0)),"^",2)
    86          . I 'YSCLDA S YSCLER=" is not in the local database." D OUT Q
    87          . D CL1^YSCLTST2(YSCLDA,YSA) D
    88          . . S YSCLDA1="" F  S YSCLDA1=$O(^TMP($J,"PSO",YSCLDA1)) Q:'YSCLDA1  S YSCLER=" = "_YSCLDA_"="_(9999999-YSCLDA1)_" = "_^TMP($J,"PSO",YSCLDA1)_" at " D OUT
    89          . Q
    90          G EXIT^YSCLSERV
    91         Q
    92 DCON    ;
    93         F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
    94          . ;Verify that a valid Clozapine number is listed
    95          . S (YSA,YSCLDA)=$E(XMRG,1,7)
    96          . I YSCLDA'?2U5N S YSCLER=" is not a valid Clozapine number " D OUT Q
    97          . S YSCLDA=$O(^YSCL(603.01,"B",YSCLDA,"")),YSCLDA=$P($G(^YSCL(603.01,YSCLDA,0)),"^",2)
    98          . I 'YSCLDA S YSCLER=" is not in the local database." D OUT Q
    99          . I $P(^PS(55,YSCLDA,"SAND"),"^",2)'="D" S YSCLER=YSA_" is not discontinued" D OUT Q
    100          . S YSCLER=YSA_" was "_$P(^PS(55,YSCLDA,"SAND"),"^",2)_" is now ""A""" D OUT
    101          . S $P(^PS(55,YSCLDA,"SAND"),"^",2)="A"
    102 ZEOR    ;YSCLSRV2
     1YSCLSRV2 ;DALOI/RLM-Clozapine data server ;APR 24,1990@15:26
     2 ;;5.01;MENTAL HEALTH;**69,90**;Dec 30, 1994;Build 18
     3 ; Reference to ^%ZOSF supported by IA #10096
     4 ; Reference to ^DPT supported by IA #10035
     5 ; Reference to ^DD("DD" supported by IA #10017
     6 ; Reference to ^PS(55 supported by IA #787
     7 ; Reference to ^PSDRUG supported by IA #25
     8 ; Reference to ^PSRX supported by IA #780
     9 ; Reference to ^VA(200 supported by IA #10060
     10 ; Reference to $$SITE^VASITE supported by IA #10112
     11 ; Reference to $$FMTE^XLFDT() supported by IA #10103
     12 ; Reference to ^PSDRUG supported by IA #221
     13 ; Reference to ^LAB(60 supported by IA #333
     14 ;
     15REPORT ;send report of current registrations to the Clozapine group on Forum
     16 S XMRG="",YSCLA=0 F  S YSCLA=$O(^YSCL(603.01,YSCLA)) Q:'YSCLA  S YSCLDTA=$G(^YSCL(603.01,YSCLA,0)) D
     17  . I YSCLDTA="" S YSCLER="Clozapine Patient List damaged at " D OUT Q
     18  . S YSCLWB=$P(YSCLDTA,"^",3),YSCLWB=$S(YSCLWB="M":"Monthly",YSCLWB="W":"Weekly",YSCLWB="B":"Bi-weekly",1:"Unknown")
     19  . S YSCLER=$P(YSCLDTA,"^")_" is assigned to "_$P($G(^DPT($P(YSCLDTA,"^",2),0)),"^")_" ("_$P($G(^DPT($P(YSCLDTA,"^",2),0)),"^",9)_") "_YSCLWB_" at " D OUT
     20 I YSCLSUB["+" S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="====" S YSCLA=0 F  S YSCLA=$O(^PS(55,"ASAND",YSCLA)) Q:'YSCLA  S YSCLER="" D  D:YSCLER]"" OUT ;Transmit the most recent for each patient.
     21  . S YSCLDFN=$P(^PS(55,YSCLA,0),"^") ;Find out who we're reporting on
     22  . S YSCLNM=$P(^DPT(YSCLDFN,0),"^") ;Get the patients name
     23  . S YSCLSD1=YSCLNM_"^"_^PS(55,YSCLA,"SAND") ;Add name to data
     24  . S YSCLZZ=YSCLA,$P(YSCLSD1,"^",4)=$P($$CL^YSCLTST2(YSCLDFN),"^",2),YSCLA=YSCLZZ
     25  . S YSCLDOC=$P(YSCLSD1,"^",6) I YSCLDOC K DIERR,YSCL200 D FIND^DIC(200,,".01","X","`"_YSCLDOC,,,,,"YSCL200","YERROR") S $P(YSCLSD1,"^",6)=$G(YSCL200("DILIST",1,1))
     26  . ;S YSCLDOC=$P(YSCLSD1,"^",6) I YSCLDOC S $P(YSCLSD1,"^",6)=$P($G(^VA(200,YSCLDOC,0)),"^") ;OLD CODE
     27  . S $P(YSCLSD1,"^",7)=$P(YSCLSD1,"^",7) ;Pad it to 7 ^-pieces
     28  . S YSCLB=0 F  S YSCLB=$O(^PS(55,YSCLA,"P",YSCLB)) Q:'YSCLB  I $D(^PSRX(^PS(55,YSCLA,"P",YSCLB,0),"SAND")) D  ;D OUT ;This will transmit them all
     29  . . S YSCLER=YSCLSD1_"^"_$G(^PSRX(^PS(55,YSCLA,"P",YSCLB,0),"SAND"))_"^"
     30  . . S Y=$P(YSCLER,"^",7) I Y]"" X ^DD("DD") S $P(YSCLER,"^",7)=Y
     31  . . S Y=$P(YSCLER,"^",10) I Y]"" X ^DD("DD") S $P(YSCLER,"^",10)=Y
     32  . ;D OUT
     33 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="  Linked Tests:"
     34 S YSCLA=0 F  S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA  D
     35  . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=$P(^LAB(60,$P(^YSCL(603.04,1,1,YSCLA,0),"^",1),0),"^")
     36  . S YSCLTYPE=$P(^YSCL(603.04,1,1,YSCLA,0),"^",2),YSCLRPT=$P(^YSCL(603.04,1,1,YSCLA,0),"^",3)
     37  . S YSCLTA="  reports  "_$S(YSCLTYPE="W":"WHITE BLOOD COUNT",YSCLTYPE="A":"ABSOLUTE NEUTROPHIL COUNT",YSCLTYPE="N":"NEUTROPHIL PERCENT",YSCLTYPE="S":"SEGS %",YSCLTYPE="B":"BANDS %",YSCLTYPE="T":"BANDS A",YSCLTYPE="C":"SEGS A")
     38  . S ^TMP($J,"YSCLDATA",YSCLLNT)=^TMP($J,"YSCLDATA",YSCLLNT)_YSCLTA_"  "_$S(YSCLRPT:"K/units",1:"units")
     39 ;Old method
     40 ;S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="  Linked Tests:"
     41 ;S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="WBC = "_$$GET1^DIQ(603.02,1,.01)_", Neut% = "_$$GET1^DIQ(603.02,1,1)
     42 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="  Monitored Drug - Monitor Routine - NDC - Lab Test"
     43 S YSPR=0 F  S YSPR=$O(^PSDRUG(YSPR)) Q:'YSPR  I $P($G(^PSDRUG(YSPR,"CLOZ1")),"^")]"" D
     44  . S YSCLTC=$P($G(^PSDRUG(YSPR,"CLOZ")),"^") I YSCLTC S YSCLTC=$$GET1^DIQ(60,YSCLTC,.01)
     45  . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=$P($G(^PSDRUG(YSPR,0)),"^")_" - "_$P(^PSDRUG(YSPR,"CLOZ1"),"^")_" - "_$P($G(^PSDRUG(YSPR,2)),"^",4)_" - "_YSCLTC
     46 S YSCLDR=0 F  S YSCLDR=$O(^PSDRUG(YSCLDR)) Q:'YSCLDR  I $D(^PSDRUG(YSCLDR,"CLOZ2")) D
     47  . S YSCLDRA=0 F  S YSCLDRA=$O(^PSDRUG(YSCLDR,"CLOZ2",YSCLDRA)) Q:'YSCLDRA  D
     48  . . S YSCLDRB=^PSDRUG(YSCLDR,"CLOZ2",YSCLDRA,0)
     49  . . S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=$P(^PSDRUG(YSCLDR,0),"^")_" uses "_$P(^LAB(60,$P(YSCLDRB,"^"),0),"^")_" to indicate "_$S($P(YSCLDRB,"^",4)=1:"White Blood Count",1:"Neutrophil Count")
     50 ;D OPTION^%ZTLOAD("YSCL WEEKLY TRANSMISSION","LIST") D
     51 ; . S ZTSK="" F  S ZTSK=$O(LIST(ZTSK)) Q:ZTSK=""  D
     52 ; . . D STAT^%ZTLOAD S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Local Task # "_ZTSK_" is "_$S('ZTSK(0):" not ",1:"")_"defined with a status of "_ZTSK(2)
     53 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="              Run day is: "_$P(^YSCL(603.03,1,0),"^",2)
     54 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="           Debug Mode is: "_$S($P(^YSCL(603.03,1,0),"^",3):"On.",1:"Off.")
     55 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Last Run Date (start) is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",4))
     56 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=" Last Run Date (stop) is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",5))
     57 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Last Demographic date is: "_$$FMTE^XLFDT($P(^YSCL(603.03,1,0),"^",6))
     58 Q
     59OUT S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)=XMRG_YSCLER_YSCLST Q
     60 ;Build the text for the return message here.
     61REBUILD ;
     62 S XMRG="",(YSCLA,YSCLLNT)=1 F  S YSCLA=$O(^PS(55,"ASAND1",YSCLA)) W:'$D(ZTQUEUED) "." Q:YSCLA=""  D
     63  . S YSCLB=$O(^PS(55,"ASAND1",YSCLA,"")) I YSCLB="" S YSCLER=" record is in error (1) at " D OUT Q
     64  . I '$D(^PS(55,YSCLB,0)) S YSCLER=" record is in error (2) at " D OUT Q
     65  . S YSCLB=$P(^PS(55,YSCLB,0),"^") I YSCLB="" S YSCLER=" record is in error (3) at " D OUT Q
     66  . I '$D(^PS(55,YSCLB,"SAND")) S YSCLER=" record is in error (4) at " D OUT Q
     67  . S DIC="^DPT(",DIC(0)="X",D="SSN",(YSCLSSN,X)=$P(^DPT(YSCLB,0),"^",9)
     68  . I $D(^YSCL(603.01,"B",YSCLA)) S YSCLX=$O(^YSCL(603.01,"B",YSCLA,"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=" Clozapine # "_YSCLA_" is in use by "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT Q
     69  . D MIX^DIC1 S YSCLPT=+Y I Y=-1 S YSCLER=" could not be added at " D OUT Q
     70  . K DD S DIC="^YSCL(603.01,",X=YSCLA,DIC("DR")="1////"_YSCLPT K DO D FILE^DICN
     71  . S YSCLX=$O(^YSCL(603.01,"B",YSCLA,"")) S:YSCLX]"" YSCLX=$P(^YSCL(603.01,YSCLX,0),"^",2),YSCLER=","_YSCLSSN_" assigned to "_$P($G(^DPT(YSCLX,0)),"^")_" at " D OUT
     72 Q
     73OVRRID ;Update record with Monthly, Weekly or Bi-weekly status
     74 F  X XMREC Q:XMER<0  S XMRG=$TR(XMRG,"- ","") D
     75  . I XMRG'?2U5N1","9N1",".E S YSCLER=" is in error and was not added at " D OUT Q
     76  . I $P(XMRG,",")'?2U5N S YSCLER=" is not a valid Clozapine number format " D OUT Q
     77  . I $P(XMRG,",",2)'?9N S YSCLER=" An SSN must be 9 numbers " D OUT Q
     78  . K %DT S X=$P(XMRG,",",3),%DT="F" D ^%DT I Y=-1 S YSCLER=" is an invalid date, over-ride authorization not filed at " D OUT Q
     79  . S YSCLOVR=Y
     80  . S YSCLNM=$P(XMRG,","),YSCLSSN=$P(XMRG,",",2),YSCLWB=$P(XMRG,",",3)
     81  . I '$D(^YSCL(603.01,"B",YSCLNM)) S YSCLER=" does not exist at " D OUT Q
     82  . S YSCLDA=$O(^DPT("SSN",YSCLSSN,0))
     83  . I YSCLDA="" S YSCLER=" SSN does not exist at " D OUT Q
     84  . I $O(^YSCL(603.01,"B",YSCLNM,0))="" S YSCLER=" SSN not in Clozapine file " D OUT Q
     85  . I $O(^DPT("SSN",YSCLSSN,YSCLDA)) S YSCLER=" SSN has more than one owner " D OUT Q
     86  . I $O(^YSCL(603.01,"B",YSCLNM,0))'=$O(^YSCL(603.01,"C",YSCLDA,0)) S YSCLER=" SSN ("_YSCLSSN_","_$P(^DPT(YSCLDA,0),"^")_") has multiple Clozapine Numbers at " D OUT
     87  . I $O(^YSCL(603.01,"B",YSCLNM,0))=$O(^YSCL(603.01,"C",YSCLDA,0)) D
     88  . . S YSCLDA1=$O(^YSCL(603.01,"B",YSCLNM,0)) S $P(^YSCL(603.01,YSCLDA1,0),"^",4)=YSCLOVR
     89  . . S Y=YSCLOVR D DD^%DT S YSCLER=" "_YSCLNM_" ("_$P(^DPT(YSCLDA,0),"^")_") authorized for over-ride on "_Y_" at " D OUT
     90 G EXIT^YSCLSERV
     91ZEOR ;YSCLSRV2
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLSRV3.m

    r613 r623  
    1 YSCLSRV3        ;DALOI/RLM-Clozapine data server ;24 APR 1990
    2         ;;5.01;MENTAL HEALTH;**74,90,92**;Dec 30, 1994;Build 7
    3         ; Reference to ^%ZOSF supported by IA #10096
    4         ; Reference to ^DPT supported by IA #10035
    5         ; Reference to ^PS(55 supported by IA #787
    6         ; Reference to ^PSDRUG supported by IA #25
    7         ; Reference to ^PSRX supported by IA #780
    8         ; Reference to ^VA(200 supported by IA #10060
    9         ; Reference to ^XUSEC supported by IA #10076
    10         ;
    11         S ^TMP($J,"YSCLDATA",1)="This routine will print a list of all active Clozapine prescriptions."
    12         S ^TMP($J,"YSCLDATA",2)="An asterisk in the first column indicates that the prescription is over"
    13         S ^TMP($J,"YSCLDATA",3)="28 days old.  The second column is the Patient Name.  The third is the"
    14         S ^TMP($J,"YSCLDATA",4)="Issue Date.  The fourth column is the Prescription Number. The final"
    15         S ^TMP($J,"YSCLDATA",5)="column is the CLOZAPINE STATUS indicator."
    16         S X1=DT,X2=-28 D C^%DTC S YSCL28=X
    17         S DFN=0,YSCLLN=6
    18         F  K YSCLA S DFN=$O(^PS(55,"ASAND",DFN)),YSCLLD=0 Q:'DFN  I $D(^DPT(DFN,0)),$D(^PS(55,DFN,"SAND")) S YSCLSAND=^("SAND"),YSCL=^DPT(DFN,0),YSCLX=$E($P($P(YSCL,"^"),",",2))_$E(YSCL)_"^"_$P(YSCL,"^",9) D
    19         . F YSCL=0:0 S YSCL=$O(^PS(55,DFN,"P",YSCL)) Q:'YSCL  I $D(^(YSCL,0)) S YSCL1=^(0) I $D(^PSRX(YSCL1,0)) D ACTIVE I 'YSACT S YSCLRX=^PSRX(YSCL1,0) I $P($G(^PSDRUG(+$P(YSCLRX,"^",6),"CLOZ1")),"^")="PSOCLO1",$D(^("CLOZ")) S YSCLLAB=^("CLOZ") D
    20         . . ;W !,DFN," - ",YSCL1
    21         . . S ^TMP($J,"YSCLDATA",YSCLLN)=$S(YSCL28>$P(YSCLRX,"^",13):"*",1:" ")_"^"_$P(^DPT($P(YSCLRX,"^",2),0),"^")_"^"_$$FMTE^XLFDT($P(YSCLRX,"^",13))_"^"_$P(YSCLRX,"^")_"^"_$P(YSCLSAND,"^",2)
    22         . . S YSCLLN=YSCLLN+1
    23         G EXIT^YSCLSERV
    24         Q
    25 ACTIVE  ;
    26         S YSACT=$$GET1^DIQ(52,YSCL1_",",100,"I","ERR")
    27         Q
    28 DEMOG   ;
    29         S YSCLA=0 F  S YSCLA=$O(^YSCL(603.01,"C",YSCLA)) Q:'YSCLA  D
    30         . I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4)=0 S YSCLC=$G(YSCLC)+1
    31         . I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4) S $P(^PS(55,YSCLA,"SAND"),"^",4)=0,YSCLB=$G(YSCLB)+1
    32         S ^TMP($J,"YSCLDATA",2)=+$G(YSCLB)_" record"_$S(+$G(YSCLB)=1:"",1:"s")_" reset at ("_YSCLST_") "_YSCLSTN
    33         S ^TMP($J,"YSCLDATA",3)=+$G(YSCLC)_" record"_$S(+$G(YSCLC)=1:"",1:"s")_" not reset at ("_YSCLST_") "_YSCLSTN
    34         G EXIT^YSCLSERV
    35         Q
    36 LOCK    ;Lock out ability to dispense Clozapine
    37         X XMREC Q:XMER<0  S X=XMRG
    38         I X="LOCK DOWN ON" S $P(^YSCL(603.03,1,1),"^",1)=1 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Clozapine dispensing prohibited at "_YSCLST
    39         I X="LOCK DOWN OFF" S $P(^YSCL(603.03,1,1),"^",1)=0 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Clozapine dispensing enabled at "_YSCLST
    40         G EXIT^YSCLSERV
    41         Q
    42 AUTH    ;List authorized Clozapine providers
    43         I YSCLSUB["LIST" D  G EXIT^YSCLSERV
    44          . S ^TMP($J,"YSCLDATA",1)="The following providers are authorized to override Clozapine lockouts (PSOLOCKCLOZ)"
    45         . S YSCLLN=2
    46         . S YSCLA="" F  S YSCLA=$O(^XUSEC("PSOLOCKCLOZ",YSCLA)) Q:YSCLA=""  D
    47         . . Q:'$D(^VA(200,YSCLA,0))
    48         . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P(^VA(200,YSCLA,0),"^",1)_"  "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive",YSCLLN=YSCLLN+1
    49         . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
    50         . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
    51         . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
    52          . S ^TMP($J,"YSCLDATA",YSCLLN)="The following providers are authorized to access the Pharmacy Clozapine Manager Menu (PSZ CLOZAPINE)",YSCLLN=YSCLLN+1
    53         . S YSCLA="" F  S YSCLA=$O(^XUSEC("PSZ CLOZAPINE",YSCLA)) Q:YSCLA=""  D
    54         . . Q:'$D(^VA(200,YSCLA,0))
    55         . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P(^VA(200,YSCLA,0),"^",1)_"  "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive",YSCLLN=YSCLLN+1
    56         . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
    57         . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
    58         . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
    59          . S ^TMP($J,"YSCLDATA",YSCLLN)="The following providers are authorized to prescribe Clozapine (YSCL AUTHORIZED)",YSCLLN=YSCLLN+1
    60         . S YSCLA=0 F  S YSCLA=$O(^XUSEC("YSCL AUTHORIZED",YSCLA)) Q:'YSCLA  D  ;??? Use FileMan lookup on 200
    61         . . S YSCLDEA=$$DEA^XUSER(1,YSCLA),YSCLYN=1,YSCLSSN=$P(^VA(200,YSCLA,1),"^",9)
    62         . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P($G(^VA(200,YSCLA,0)),"^",1)_" - "_YSCLSSN_" - "_$S(YSCLDEA="":"*NONE*",1:YSCLDEA)_" - "_$S(YSCLYN=1:"Yes",1:"NO"),YSCLLN=YSCLLN+1
    63         ;Holders of YSCL AUTHORIZED key
    64         ;=============================================
    65         ;
    66         S YSCLLN=1,^TMP($J,"YSCLDATA",YSCLLN)="Clinician Authorization Results at "_YSCLST,YSCLLN=YSCLLN+1
    67         K ^TMP("DIERR",$J)
    68         F  X XMREC Q:XMER<0  S X=XMRG X ^%ZOSF("UPPERCASE") S X=Y D
    69         . S YSCLSSN=$P(X,"^",1),YSCLDEA=$P(X,"^",2),YSCLYN=$P(X,"^",3),YSCLDUZ="",YSCLDEA1="",YSCLIEN=""
    70         . I YSCLLN=""!("YESNO"'[YSCLYN) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician Authorization instructions invalid ("_YSCLYN_") at "_YSCLST,YSCLLN=YSCLLN+1
    71         . S YSCLYN=$S(YSCLYN="YES":1,1:0)
    72         . I '$D(^VA(200,"BS5",YSCLSSN)) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q
    73         . I $D(^VA(200,"BS5",YSCLSSN)) S YSCLAA="" F  S YSCLAA=$O(^VA(200,"BS5",YSCLSSN,YSCLAA)) Q:YSCLAA=""  I $$DEA^XUSER(1,YSCLAA)=YSCLDEA S YSCLDUZ=YSCLAA Q
    74         . I YSCLDUZ="" S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") with DEA# "_YSCLDEA_" does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q
    75         . S YSCLDEA1=$$DEA^XUSER(1,YSCLDUZ)
    76         . I YSCLDEA1="" S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician with DEA# "_YSCLDEA_" does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q
    77         . I YSCLDEA'=YSCLDEA1 W ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN ("_YSCLSSN_") - DEA ("_YSCLDEA_") mismatch at "_YSCLST,YSCLLN=YSCLLN+1 Q
    78         . D OWNSKEY^XUSRB(.RET,"YSCL AUTHORIZED",YSCLDUZ)
    79         . I RET(0),YSCLYN S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") already authorized at "_YSCLST,YSCLLN=YSCLLN+1 Q
    80         . I 'RET(0),'YSCLYN S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") not authorized at "_YSCLST,YSCLLN=YSCLLN+1 Q
    81         . I 'RET(0),YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D  S DUZ(0)=YSCLDUZ(0)
    82         . . S YSCLFDA(200,"?1,",.01)="`"_YSCLDUZ
    83         . . S YSCLFDA(200.051,"+2,?1,",.01)="YSCL AUTHORIZED" D UPDATE^DIE("E","YSCLFDA",,"YSCLERR")
    84         . . I $D(YSCLERR) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization failed at "_YSCLST,YSCLLN=YSCLLN+1 Q
    85         . . I '$D(YSCLERR) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization set to "_$S(YSCLYN=1:"Yes",1:"No")_" at "_YSCLST,YSCLLN=YSCLLN+1 Q
    86         . I RET(0),'YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D  S DUZ(0)=YSCLDUZ(0)
    87         . . S DA=$$FIND1^DIC(200.051,","_YSCLDUZ_",","A","YSCL AUTHORIZE")
    88         . . I DA<1 S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization removal failed at "_YSCLST,YSCLLN=YSCLLN+1 Q
    89         . . S DA(1)=YSCLDUZ,DIK="^VA(200,"_DA(1)_",51," D ^DIK
    90         . . S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization removed at "_YSCLST,YSCLLN=YSCLLN+1 Q
    91         G EXIT^YSCLSERV
    92         Q
    93 ZEOR    ;YSCLSRV3
     1YSCLSRV3 ;DALOI/RLM-Clozapine data server ;24 APR 1990
     2 ;;5.01;MENTAL HEALTH;**74,90**;Dec 30, 1994;Build 18
     3 ; Reference to ^%ZOSF supported by IA #10096
     4 ; Reference to ^DPT supported by IA #10035
     5 ; Reference to ^PS(55 supported by IA #787
     6 ; Reference to ^PSDRUG supported by IA #25
     7 ; Reference to ^PSRX supported by IA #780
     8 ; Reference to ^VA(200 supported by IA #10060
     9 ; Reference to ^XUSEC supported by IA #10076
     10 ;
     11 S ^TMP($J,"YSCLDATA",1)="This routine will print a list of all active Clozapine prescriptions."
     12 S ^TMP($J,"YSCLDATA",2)="An asterisk in the first column indicates that the prescription is over"
     13 S ^TMP($J,"YSCLDATA",3)="28 days old.  The second column is the Patient Name.  The third is the"
     14 S ^TMP($J,"YSCLDATA",4)="Issue Date.  The fourth column is the Prescription Number. The final"
     15 S ^TMP($J,"YSCLDATA",5)="column is the CLOZAPINE STATUS indicator."
     16 S X1=DT,X2=-28 D C^%DTC S YSCL28=X
     17 S DFN=0,YSCLLN=6
     18 F  K YSCLA S DFN=$O(^PS(55,"ASAND",DFN)),YSCLLD=0 Q:'DFN  I $D(^DPT(DFN,0)),$D(^PS(55,DFN,"SAND")) S YSCLSAND=^("SAND"),YSCL=^DPT(DFN,0),YSCLX=$E($P($P(YSCL,"^"),",",2))_$E(YSCL)_"^"_$P(YSCL,"^",9) D
     19  . F YSCL=0:0 S YSCL=$O(^PS(55,DFN,"P",YSCL)) Q:'YSCL  I $D(^(YSCL,0)) S YSCL1=^(0) I $D(^PSRX(YSCL1,0)) D ACTIVE I 'YSACT S YSCLRX=^PSRX(YSCL1,0) I $P($G(^PSDRUG(+$P(YSCLRX,"^",6),"CLOZ1")),"^")="PSOCLO1",$D(^("CLOZ")) S YSCLLAB=^("CLOZ") D
     20  . . ;W !,DFN," - ",YSCL1
     21  . . S ^TMP($J,"YSCLDATA",YSCLLN)=$S(YSCL28>$P(YSCLRX,"^",13):"*",1:" ")_"^"_$P(^DPT($P(YSCLRX,"^",2),0),"^")_"^"_$$FMTE^XLFDT($P(YSCLRX,"^",13))_"^"_$P(YSCLRX,"^")_"^"_$P(YSCLSAND,"^",2)
     22  . . S YSCLLN=YSCLLN+1
     23 G EXIT^YSCLSERV
     24 Q
     25ACTIVE ;
     26 S YSACT=$$GET1^DIQ(52,YSCL1_",",100,"I","ERR")
     27 Q
     28DEMOG ;
     29 S YSCLA=0 F  S YSCLA=$O(^YSCL(603.01,"C",YSCLA)) Q:'YSCLA  D
     30  . I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4)=0 S YSCLC=$G(YSCLC)+1
     31  . I $D(^PS(55,YSCLA,"SAND")),$P(^PS(55,YSCLA,"SAND"),"^",4) S $P(^PS(55,YSCLA,"SAND"),"^",4)=0,YSCLB=$G(YSCLB)+1
     32 S ^TMP($J,"YSCLDATA",2)=+$G(YSCLB)_" record"_$S(+$G(YSCLB)=1:"",1:"s")_" reset at ("_YSCLST_") "_YSCLSTN
     33 S ^TMP($J,"YSCLDATA",3)=+$G(YSCLC)_" record"_$S(+$G(YSCLC)=1:"",1:"s")_" not reset at ("_YSCLST_") "_YSCLSTN
     34 G EXIT^YSCLSERV
     35 Q
     36LOCK ;Lock out ability to dispense Clozapine
     37 X XMREC Q:XMER<0  S X=XMRG
     38 I X="LOCK DOWN ON" S $P(^YSCL(603.03,1,1),"^",1)=1 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Clozapine dispensing prohibited at "_YSCLST
     39 I X="LOCK DOWN OFF" S $P(^YSCL(603.03,1,1),"^",1)=0 S YSCLLNT=$G(YSCLLNT)+1,^TMP($J,"YSCLDATA",YSCLLNT)="Clozapine dispensing enabled at "_YSCLST
     40 G EXIT^YSCLSERV
     41 Q
     42AUTH ;List authorized Clozapine providers
     43 I YSCLSUB["LIST" D  G EXIT^YSCLSERV
     44  . S ^TMP($J,"YSCLDATA",1)="The following providers are authorized to override Clozapine lockouts"
     45  . S YSCLLN=2
     46  . S YSCLA="" F  S YSCLA=$O(^XUSEC("PSOLOCKCLOZ",YSCLA)) Q:YSCLA=""  D
     47  . . Q:'$D(^VA(200,YSCLA,0))
     48  . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P(^VA(200,YSCLA,0),"^",1)_"  "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive",YSCLLN=YSCLLN+1
     49  . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
     50  . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
     51  . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
     52  . S ^TMP($J,"YSCLDATA",YSCLLN)="The following providers are authorized to access the Pharmacy Clozapine Manager Menu",YSCLLN=YSCLLN+1
     53  . S YSCLA="" F  S YSCLA=$O(^XUSEC("PSZ CLOZAPINE",YSCLA)) Q:YSCLA=""  D
     54  . . Q:'$D(^VA(200,YSCLA,0))
     55  . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P(^VA(200,YSCLA,0),"^",1)_"  "_$S($P(^VA(200,YSCLA,0),"^",7)=1:"Ina",1:"A")_"ctive",YSCLLN=YSCLLN+1
     56  . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
     57  . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
     58  . S ^TMP($J,"YSCLDATA",YSCLLN)="",YSCLLN=YSCLLN+1
     59  . S ^TMP($J,"YSCLDATA",YSCLLN)="The following providers are authorized to prescribe Clozapine",YSCLLN=YSCLLN+1
     60  . S YSCLA=0 F  S YSCLA=$O(^XUSEC("YSCL AUTHORIZED",YSCLA)) Q:'YSCLA  D  ;??? Use FileMan lookup on 200
     61  . . S YSCLDEA=$$DEA^XUSER(1,YSCLA),YSCLYN=1,YSCLSSN=$P(^VA(200,YSCLA,1),"^",9)
     62  . . S ^TMP($J,"YSCLDATA",YSCLLN)=$P($G(^VA(200,YSCLA,0)),"^",1)_" - "_YSCLSSN_" - "_$S(YSCLDEA="":"*NONE*",1:YSCLDEA)_" - "_$S(YSCLYN=1:"Yes",1:"NO"),YSCLLN=YSCLLN+1
     63 ;Holders of YSCL AUTHORIZED key
     64 ;=============================================
     65 ;
     66 S YSCLLN=1,^TMP($J,"YSCLDATA",YSCLLN)="Clinician Authorization Results at "_YSCLST,YSCLLN=YSCLLN+1
     67 K ^TMP("DIERR",$J)
     68 F  X XMREC Q:XMER<0  S X=XMRG X ^%ZOSF("UPPERCASE") S X=Y D
     69  . S YSCLSSN=$P(X,"^",1),YSCLDEA=$P(X,"^",2),YSCLYN=$P(X,"^",3),YSCLDUZ="",YSCLDEA1="",YSCLIEN=""
     70  . I YSCLLN=""!("YESNO"'[YSCLYN) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician Authorization instructions invalid ("_YSCLYN_") at "_YSCLST,YSCLLN=YSCLLN+1
     71  . S YSCLYN=$S(YSCLYN="YES":1,1:0)
     72  . I '$D(^VA(200,"BS5",YSCLSSN)) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q
     73  . I $D(^VA(200,"BS5",YSCLSSN)) S YSCLAA="" F  S YSCLAA=$O(^VA(200,"BS5",YSCLSSN,YSCLAA)) Q:YSCLAA=""  I $$DEA^XUSER(1,YSCLAA)=YSCLDEA S YSCLDUZ=YSCLAA Q
     74  . I YSCLDUZ="" S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") with DEA# "_YSCLDEA_" does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q
     75  . S YSCLDEA1=$$DEA^XUSER(1,YSCLDUZ)
     76  . I YSCLDEA1="" S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician with DEA# "_YSCLDEA_" does not exist at "_YSCLST,YSCLLN=YSCLLN+1 Q
     77  . I YSCLDEA'=YSCLDEA1 W ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN ("_YSCLSSN_") - DEA ("_YSCLDEA_") mismatch at "_YSCLST,YSCLLN=YSCLLN+1 Q
     78  . D OWNSKEY^XUSRB(.RET,"YSCL AUTHORIZED",YSCLDUZ)
     79  . I RET(0),YSCLYN S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") already authorized at "_YSCLST,YSCLLN=YSCLLN+1 Q
     80  . I 'RET(0),'YSCLYN S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician ("_YSCLSSN_") not authorized at "_YSCLST,YSCLLN=YSCLLN+1 Q
     81  . I 'RET(0),YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D  S DUZ(0)=YSCLDUZ(0)
     82  . . S YSCLFDA(200,"?1,",.01)="`"_YSCLDUZ
     83  . . S YSCLFDA(200.051,"+2,?1,",.01)="YSCL AUTHORIZED" D UPDATE^DIE("E","YSCLFDA",,"YSCLERR")
     84  . . I $D(YSCLERR) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization failed at "_YSCLST,YSCLLN=YSCLLN+1 Q
     85  . . I '$D(YSCLERR) S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization set to "_$S(YSCLYN=1:"Yes",1:"No")_" at "_YSCLST,YSCLLN=YSCLLN+1 Q
     86  . I RET(0),'YSCLYN S YSCLDUZ(0)=DUZ,DUZ(0)="@" D  S DUZ(0)=YSCLDUZ(0)
     87  . . S DA=$$FIND1^DIC(200.051,","_YSCLDUZ_",","A","YSCL AUTHORIZE")
     88  . . I DA<1 S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization removal failed at "_YSCLST,YSCLLN=YSCLLN+1 Q
     89  . . S DA(1)=YSCLDUZ,DIK="^VA(200,"_DA(1)_",51," D ^DIK
     90  . . S ^TMP($J,"YSCLDATA",YSCLLN)="Clinician SSN "_YSCLSSN_" authorization removed at "_YSCLST,YSCLLN=YSCLLN+1 Q
     91 G EXIT^YSCLSERV
     92 Q
     93ZEOR ;YSCLSRV3
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSCLTST2.m

    r613 r623  
    1 YSCLTST2        ;DALOI/LB/RLM-TRANSMIT RX AND lAB DATA FOR CLOZAPINE ;19 Feb 93
    2         ;;5.01;MENTAL HEALTH;**18,22,26,47,61,69,74,90,92**;Dec 30, 1994;Build 7
    3         ; Reference to ^LAB(60 supported by IA #333
    4         ; Reference to ^PSDRUG supported by IA #25
    5         ; Reference to ^XMD supported by IA #10070
    6         ;
    7 TRANSMIT        ; send remote and local, kill and quit
    8         K XMZ S %DT="T",X="NOW" D ^%DT S YSCLNOW=$P(Y,".",2),YSCLSITE=$P($$SITE^VASITE,"^",2)
    9         S $P(YSSTOP,",",7)=7 I $$S^%ZTLOAD D ABORT^YSCLTEST G END
    10         I YSCLLN D
    11          . K XMY
    12          . S XMY("S.RUCLRXLAB@FO-HINES.MED.VA.GOV")=""
    13          . I YSDEBUG K XMY S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")="",XMY("G.RUCLRXLAB@FO-DALLAS.MED.VA.GOV")=""
    14          . S XMDUZ="Clozapine MONITOR",XMTEXT="^TMP($J,",XMSUB=$S(YSDEBUG:"DEBUG ",1:"")_"Clozapine lab data @ "_YSCLSITE_" on "_DT_" at "_YSCLNOW D ^XMD
    15         K XMY
    16         S XMY("G.CLOZAPINE ROLL-UP@FORUM.VA.GOV")=""
    17         I YSDEBUG K XMY S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")=""
    18         S XMY("G.PSOCLOZ")=""
    19         S XMSUB=$S(YSDEBUG:"DEBUG ",1:"")_"Clozapine lab data @ "_YSCLSITE_" on "_DT_" at "_YSCLNOW
    20         S ^TMP("YSCL",$J,2,0)=" ",^TMP("YSCL",$J,3,0)="In message # "_$S($D(XMZ):XMZ,1:"no data sent")
    21         K XMZ S XMDUZ="Clozapine MONITOR",^TMP("YSCL",$J,1,0)="Clozapine lab data was transmitted, "_(YSCLLLN-3)_" records were sent",XMTEXT="^TMP(""YSCL"",$J," D ^XMD
    22         S $P(^YSCL(603.03,1,0),"^",5)=$$NOW^XLFDT
    23 END     ;
    24         G END1^YSCLTST3
    25         Q
    26 REXMIT  ; retransmit lab and RX data
    27         ; must be a tuesday
    28         S DIR(0)="Y",DIR("A")="Are you sure you wish to retransmit lab data"
    29         D ^DIR K DIR I Y'=1 K Y Q
    30 DATE    S %DT="AEXP",%DT(0)=-DT,%DT("A")="Ending date for data collection (must be a tuesday )"
    31         D ^%DT K %DT G END:X="^",END:X="^" I Y=-1 G DATE
    32 SERV    S YSCLED=Y,X=Y D H^%DTC I %H#7'=5 W !,"MUST BE A TUESDAY" G DATE
    33         S ZTDESC="Server triggered retransmission"
    34         S ZTSAVE("YSCLED")="",ZTIO="",ZTRTN="REXMIT^YSCLTEST",ZTDTH=$H D ^%ZTLOAD G END
    35 FLSET   ;Set up file 603.02
    36         W @IOF,"This option specifies the blood tests associated with the Clozapine"
    37         W !,"reporting software.  Two tests must be defined.  The first is the White"
    38         W !,"Blood Count.  The second is the Granulocyte (or Neutrophil) percentage."
    39         K DIR W !! S DIR(0)="PA^64:EMZ",DIR("A",1)="Enter the test that will be used to record the White Blood Count for the",DIR("A")="Clozapine patients: " D ^DIR
    40         Q:Y=-1!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))!($D(DIROUT))
    41         S YSCLWBC=+Y
    42         K DIR W !! S DIR(0)="PA^64:EMZ",DIR("A",1)="Enter the test that will be used to record the Neutrophil Count (percentage)",DIR("A")=" for the Clozapine patients: " D ^DIR
    43         Q:Y=-1!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))!($D(DIROUT))
    44         S YSCLGRN=+Y
    45         I YSCLWBC,YSCLGRN S ^YSCL(603.02,1,0)=YSCLWBC_"^"_YSCLGRN,$P(^YSCL(603.02,0),"^",3,4)="1^1"
    46         ;Only one entry is allowed.
    47         K DIR,X,Y,YSCLWBC,YSCLGRN,ZTDESC
    48         Q
    49 EN(DRG) ;
    50         K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q
    51         I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D
    52          . S (CNT,I)=0 F  S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  S CNT=$G(CNT)+1
    53          . I CNT'=2 S LAB("BAD TEST")=0 K CNT Q
    54          . K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  D
    55          . . S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4)
    56         K LABT,I
    57         Q
    58 CL1(DFN,DAYS)   ;The routine was split due to size
    59         G CL1^YSCLTST4
    60         Q
    61         ;
    62 CL(DFN) ;
    63         K ^TMP("LRRR",$J) N RESULTS,YSCLYWBC,YSCLRANC,YSCLXWBC,YSCLRWBC,YSCLFRQ
    64         I 'DFN Q "-1^-1^-1^-1^-1^-1^-1"
    65         S YSCLFRQ=$O(^YSCL(603.01,"C",DFN,"")) I YSCLFRQ]""  S YSCLFRQ=$P(^YSCL(603.01,YSCLFRQ,0),"^",3)
    66         I $G(^YSCL(603.03,1,1))=1!(YSCLFRQ="")  Q "-1^0^0^0^0^0^"_YSCLFRQ
    67         S X1=DT,X2="-7" D C^%DTC S YSCLSD=X
    68         S YSCLA=0 F  S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA  S YSCLTLS=^YSCL(603.04,1,1,YSCLA,0),YSCLTLS($P(YSCLTLS,"^",2),$P(YSCLTLS,"^",1))=$P(YSCLTLS,"^",3)
    69         S YSCLTL="" F  S YSCLTL=$O(^YSCL(603.04,1,1,"B",YSCLTL)) Q:'YSCLTL  D
    70          . D RR^LR7OR1(DFN,,YSCLSD,DT,,YSCLTL,"L")
    71          . S YSCLSB1="" F  S YSCLSB1=$O(^TMP("LRRR",$J,DFN,YSCLSB1)) Q:YSCLSB1=""  D
    72          . . S YSCLTDT="" F  S YSCLTDT=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT)) Q:YSCLTDT=""  I $P(YSCLTDT,".",2)]"" D
    73          . . . S YSCLTA="" F  S YSCLTA=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)) Q:YSCLTA=""  I YSCLTA D
    74          . . . . S RESULTS1=^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)
    75          . . . . S RESULTS(YSCLTL,YSCLTDT)=$P(RESULTS1,"^",2)
    76         ;Find all entries for WBC and sort by inverse date.
    77         S YSCLA="" F  S YSCLA=$O(YSCLTLS("W",YSCLA)) Q:'YSCLA  S YSCLXWBC(YSCLA)="" D
    78          . S YSCLA1="" F  S YSCLA1=$O(RESULTS(YSCLA,YSCLA1)) Q:'YSCLA1  S YSCLYWBC(YSCLA1)=RESULTS(YSCLA,YSCLA1)_"^"_$P($G(^LAB(60,YSCLA,0)),"^")_"^"_YSCLTLS("W",YSCLA)
    79         S YSCLRWBC=$O(YSCLYWBC(0)) I 'YSCLRWBC D KILL Q "0^^^^^^"_YSCLFRQ
    80         S YSCLMULT=$P(YSCLYWBC(YSCLRWBC),"^",3),YSCLMULT=$S(YSCLMULT:1000,1:1)
    81         S YSCLRWBC(YSCLRWBC)=($P(YSCLYWBC(YSCLRWBC),"^")*YSCLMULT)_"^"_$P(YSCLYWBC(YSCLRWBC),"^",2)
    82         ;Scan for Neutrophil count on same day and time as most recent WBC
    83         S YSCLMTCH=0 F YSCLA="A","N","S","T" S YSCLTPT="" Q:YSCLMTCH  F  S YSCLTPT=$O(YSCLTLS(YSCLA,YSCLTPT)) Q:'YSCLTPT  D  Q:YSCLMTCH
    84          . S YSCLMULT=YSCLTLS(YSCLA,YSCLTPT),YSCLMULT=$S(YSCLMULT:1000,1:1)
    85          . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="A",RESULTS(YSCLTPT,YSCLRWBC)'?1A.E S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=RESULTS(YSCLTPT,YSCLRWBC)*YSCLMULT_"^"_$P(^LAB(60,YSCLTPT,0),"^") Q
    86          . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="N",RESULTS(YSCLTPT,YSCLRWBC)'?1A.E S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC))*.01)_"^"_$P(^LAB(60,YSCLTPT,0),"^") Q
    87          . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="S",RESULTS(YSCLTPT,YSCLRWBC)'?1A.E D
    88          . . S YSCLSGS="" F  S YSCLSGS=$O(YSCLTLS("B",YSCLSGS)) D  Q:YSCLMTCH
    89          . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0
    90          . . . S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)+(RESULTS(YSCLSGS,YSCLRWBC)*.01))_"^"_$P(^LAB(60,YSCLTPT,0),"^")_"/"_$P($G(^LAB(60,YSCLSGS,0)),"^") Q
    91          . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="C",RESULTS(YSCLTPT,YSCLRWBC)'?1A.E D
    92          . . S YSCLSGS="" F  S YSCLSGS=$O(YSCLTLS("T",YSCLSGS)) D  Q:YSCLMTCH
    93          . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0
    94          . . . S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=((RESULTS(YSCLTPT,YSCLRWBC)*YSCLMULT)+(RESULTS(YSCLSGS,YSCLRWBC)*YSCLMULT))_"^"_$P(^LAB(60,YSCLTPT,0),"^")_"/"_$P($G(^LAB(60,YSCLSGS,0)),"^") Q
    95         D KILL
    96         I $G(YSCLRWBC(YSCLRWBC))<3000!($G(YSCLRANC(YSCLRWBC))<1500) Q "0^"_$G(YSCLRWBC(YSCLRWBC))_"^"_$S($G(YSCLRANC(YSCLRWBC))="":"^",1:$G(YSCLRANC(YSCLRWBC)))_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ
    97         I $G(YSCLRWBC(YSCLRWBC))<3500!($G(YSCLRANC(YSCLRWBC))<2000) Q "2^"_$G(YSCLRWBC(YSCLRWBC))_"^"_$S($G(YSCLRANC(YSCLRWBC))="":"^",1:$G(YSCLRANC(YSCLRWBC)))_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ
    98         Q "1^"_YSCLRWBC(YSCLRWBC)_"^"_YSCLRANC(YSCLRWBC)_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ
    99         ;
    100 KILL    ;
    101         K FDA,YSCLSGS,Y15,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD,YSCLTA,YSCLMULT
    102         K YSCLTL,YSCLTLS,X1,X2
    103         Q
    104         ;
    105 OVERRIDE(DFN)   ;Check for an over-ride.
    106         S YSCLOVR=$O(^YSCL(603.01,"C",DFN,""))
    107         Q:YSCLOVR="" 0
    108         S YSCLOVR=$P(^YSCL(603.01,YSCLOVR,0),"^",4)
    109         Q YSCLOVR=DT
    110         ;
    111 ZEOR    ;YSCLTST2
     1YSCLTST2 ;DALOI/LB/RLM-TRANSMIT RX AND lAB DATA FOR CLOZAPINE ;19 Feb 93
     2 ;;5.01;MENTAL HEALTH;**18,22,26,47,61,69,74,90**;Dec 30, 1994;Build 18
     3 ; Reference to ^LAB(60 supported by IA #333
     4 ; Reference to ^PSDRUG supported by IA #25
     5 ; Reference to ^XMD supported by IA #10070
     6 ;
     7TRANSMIT ; send remote and local, kill and quit
     8 K XMZ S %DT="T",X="NOW" D ^%DT S YSCLNOW=$P(Y,".",2),YSCLSITE=$P($$SITE^VASITE,"^",2)
     9 S $P(YSSTOP,",",7)=7 I $$S^%ZTLOAD D ABORT^YSCLTEST G END
     10 I YSCLLN D
     11  . K XMY
     12  . S XMY("S.RUCLRXLAB@FO-HINES.MED.VA.GOV")=""
     13  . I YSDEBUG K XMY S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")="",XMY("G.RUCLRXLAB@FO-DALLAS.MED.VA.GOV")=""
     14  . S XMDUZ="Clozapine MONITOR",XMTEXT="^TMP($J,",XMSUB=$S(YSDEBUG:"DEBUG ",1:"")_"Clozapine lab data @ "_YSCLSITE_" on "_DT_" at "_YSCLNOW D ^XMD
     15 K XMY
     16 S XMY("G.CLOZAPINE ROLL-UP@FORUM.VA.GOV")=""
     17 I YSDEBUG K XMY S XMY("G.CLOZAPINE DEBUG@FO-DALLAS.MED.VA.GOV")=""
     18 S XMY("G.PSOCLOZ")=""
     19 S XMSUB=$S(YSDEBUG:"DEBUG ",1:"")_"Clozapine lab data @ "_YSCLSITE_" on "_DT_" at "_YSCLNOW
     20 S ^TMP("YSCL",$J,2,0)=" ",^TMP("YSCL",$J,3,0)="In message # "_$S($D(XMZ):XMZ,1:"no data sent")
     21 K XMZ S XMDUZ="Clozapine MONITOR",^TMP("YSCL",$J,1,0)="Clozapine lab data was transmitted, "_(YSCLLLN-3)_" records were sent",XMTEXT="^TMP(""YSCL"",$J," D ^XMD
     22 S $P(^YSCL(603.03,1,0),"^",5)=$$NOW^XLFDT
     23END ;
     24 G END1^YSCLTST3
     25 Q
     26REXMIT ; retransmit lab and RX data
     27 ; must be a period ending on tuesday
     28 S DIR(0)="Y",DIR("A")="Are you sure you wish to retransmit lab data"
     29 D ^DIR K DIR I Y'=1 K Y Q
     30DATE S %DT="AEXP",%DT(0)=-DT,%DT("A")="Ending date for data collection (must be a tuesday )"
     31 D ^%DT K %DT G END:X="^",END:X="^" I Y=-1 G DATE
     32SERV S YSCLED=Y,X=Y D H^%DTC I %H#7'=5 W !,"MUST BE A TUESDAY" G DATE
     33 S ZTDESC="Server triggered retransmission"
     34 S ZTSAVE("YSCLED")="",ZTIO="",ZTRTN="REXMIT^YSCLTEST",ZTDTH=$H D ^%ZTLOAD G END
     35FLSET ;Set up file 603.02
     36 W @IOF,"This option specifies the blood tests associated with the Clozapine"
     37 W !,"reporting software.  Two tests must be defined.  The first is the White"
     38 W !,"Blood Count.  The second is the Granulocyte (or Neutrophil) percentage."
     39 K DIR W !! S DIR(0)="PA^64:EMZ",DIR("A",1)="Enter the test that will be used to record the White Blood Count for the",DIR("A")="Clozapine patients: " D ^DIR
     40 Q:Y=-1!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))!($D(DIROUT))
     41 S YSCLWBC=+Y
     42 K DIR W !! S DIR(0)="PA^64:EMZ",DIR("A",1)="Enter the test that will be used to record the Neutrophil Count (percentage)",DIR("A")=" for the Clozapine patients: " D ^DIR
     43 Q:Y=-1!($D(DUOUT))!($D(DTOUT))!($D(DIRUT))!($D(DIROUT))
     44 S YSCLGRN=+Y
     45 I YSCLWBC,YSCLGRN S ^YSCL(603.02,1,0)=YSCLWBC_"^"_YSCLGRN,$P(^YSCL(603.02,0),"^",3,4)="1^1"
     46 ;Only one entry is allowed.  No cross reference is necessary. Update zeroeth node RLM 9-29-99
     47 K DIR,X,Y,YSCLWBC,YSCLGRN,ZTDESC
     48 Q
     49EN(DRG) ;
     50 K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q
     51 I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D
     52  . S (CNT,I)=0 F  S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  S CNT=$G(CNT)+1
     53  . I CNT'=2 S LAB("BAD TEST")=0 K CNT Q
     54  . K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  D
     55  . . S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LABT)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^",4)
     56 K LABT,I
     57 Q
     58CL1(DFN,DAYS) ;
     59 K ^TMP($J,"PSO"),RESULTS,YSCLYWBC,YSCLRANC,YSCLXWBC
     60 Q:'DFN
     61 S:'$G(DAYS) DAYS=90
     62 S YSCLFRQ=$O(^YSCL(603.01,"C",DFN,"")) I YSCLFRQ]""  S YSCLFRQ=$P(^YSCL(603.01,YSCLFRQ,0),"^",3)
     63 I $G(^YSCL(603.03,1,1))=1  Q "-1^0^0^0^0^0^"_YSCLFRQ
     64 S X1=DT,X2="-"_DAYS D C^%DTC S YSCLSD=X
     65 S YSCLA=0 F  S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA  S YSCLTLS=^YSCL(603.04,1,1,YSCLA,0),YSCLTLS($P(YSCLTLS,"^",2),$P(YSCLTLS,"^",1))=$P(YSCLTLS,"^",3)
     66 S YSCLTL="" F  S YSCLTL=$O(^YSCL(603.04,1,1,"B",YSCLTL)) Q:'YSCLTL  D
     67  . D RR^LR7OR1(DFN,,YSCLSD,DT,,YSCLTL,"L")
     68  . S YSCLSB1="" F  S YSCLSB1=$O(^TMP("LRRR",$J,DFN,YSCLSB1)) Q:YSCLSB1=""  D
     69  . . S YSCLTDT="" F  S YSCLTDT=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT)) Q:YSCLTDT=""  I $P(YSCLTDT,".",2)]"" D
     70  . . . S YSCLTA="" F  S YSCLTA=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)) Q:YSCLTA=""  I YSCLTA D
     71  . . . . S RESULTS1=^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)
     72  . . . . S RESULTS(YSCLTL,YSCLTDT)=$P(RESULTS1,"^",2)
     73 ;Find all entries for WBC and sort by inverse date.
     74 S YSCLA="" F  S YSCLA=$O(YSCLTLS("W",YSCLA)) Q:'YSCLA  S YSCLXWBC(YSCLA)="" D
     75  . S YSCLA1="" F  S YSCLA1=$O(RESULTS(YSCLA,YSCLA1)) Q:'YSCLA1  S YSCLYWBC(YSCLA1)=RESULTS(YSCLA,YSCLA1)*$S(YSCLTLS("W",YSCLA):1000,1:1)
     76 S YSCLRWBC=0 F  S YSCLRWBC=$O(YSCLYWBC(YSCLRWBC)) Q:YSCLRWBC=""  S YSCLRWBC(YSCLRWBC)=YSCLYWBC(YSCLRWBC) D
     77 . ;Match all ANC's and WBC's
     78 . S YSCLMTCH=0 F YSCLA="A","N","S","C" S YSCLTPT="" F  S YSCLTPT=$O(YSCLTLS(YSCLA,YSCLTPT)) Q:'YSCLTPT  D
     79 . . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="A",$D(YSCLRWBC(YSCLRWBC)) S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(RESULTS(YSCLTPT,YSCLRWBC)*$S(YSCLTLS(YSCLA,YSCLTPT):1000,1:1)) Q
     80 . . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="N",$D(YSCLRWBC(YSCLRWBC)) S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01))) Q
     81 . . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="S",$D(YSCLRWBC(YSCLRWBC)) D
     82 . . . S YSCLSGS="" F  S YSCLSGS=$O(YSCLTLS("B",YSCLSGS)) D  Q:'YSCLSGS
     83 . . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0
     84 . . . . S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_(YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)+(RESULTS(YSCLSGS,YSCLRWBC)*.01))) Q
     85 . . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="C" D
     86 . . . S YSCLSGS="" F  S YSCLSGS=$O(YSCLTLS("T",YSCLSGS)) D  Q:'YSCLSGS
     87 . . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0
     88 . . . . S ^TMP($J,"PSO",YSCLRWBC)=YSCLRWBC(YSCLRWBC)_"^"_((RESULTS(YSCLTPT,YSCLRWBC)*$S(YSCLTLS(YSCLA,YSCLTPT):1000,1:1))+(RESULTS(YSCLSGS,YSCLRWBC))) Q
     89 K FDA,YSCLSGS,Y15,YSCLRWBC,YSCLANC,YSCLYWBC,YSCLFRQ,ZIENS,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD
     90 K YSCLTA,YSCLTDT,YSCLTL,YSCLTLS,YSCLTPT,YSCLXWBC,YSCLMULT
     91 Q
     92 ;
     93 ;
     94CL(DFN) ;
     95 K ^TMP("LRRR",$J) N RESULTS,YSCLYWBC,YSCLRANC,YSCLXWBC,YSCLRWBC,YSCLFRQ
     96 I 'DFN Q "-1^-1^-1^-1^-1^-1^-1"
     97 S YSCLFRQ=$O(^YSCL(603.01,"C",DFN,"")) I YSCLFRQ]""  S YSCLFRQ=$P(^YSCL(603.01,YSCLFRQ,0),"^",3)
     98 I $G(^YSCL(603.03,1,1))=1!(YSCLFRQ="")  Q "-1^0^0^0^0^0^"_YSCLFRQ
     99 S X1=DT,X2="-7" D C^%DTC S YSCLSD=X
     100 S YSCLA=0 F  S YSCLA=$O(^YSCL(603.04,1,1,YSCLA)) Q:'YSCLA  S YSCLTLS=^YSCL(603.04,1,1,YSCLA,0),YSCLTLS($P(YSCLTLS,"^",2),$P(YSCLTLS,"^",1))=$P(YSCLTLS,"^",3)
     101 S YSCLTL="" F  S YSCLTL=$O(^YSCL(603.04,1,1,"B",YSCLTL)) Q:'YSCLTL  D
     102  . D RR^LR7OR1(DFN,,YSCLSD,DT,,YSCLTL,"L")
     103  . S YSCLSB1="" F  S YSCLSB1=$O(^TMP("LRRR",$J,DFN,YSCLSB1)) Q:YSCLSB1=""  D
     104  . . S YSCLTDT="" F  S YSCLTDT=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT)) Q:YSCLTDT=""  I $P(YSCLTDT,".",2)]"" D
     105  . . . S YSCLTA="" F  S YSCLTA=$O(^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)) Q:YSCLTA=""  I YSCLTA D
     106  . . . . S RESULTS1=^TMP("LRRR",$J,DFN,YSCLSB1,YSCLTDT,YSCLTA)
     107  . . . . S RESULTS(YSCLTL,YSCLTDT)=$P(RESULTS1,"^",2)
     108 ;Find all entries for WBC and sort by inverse date.
     109 S YSCLA="" F  S YSCLA=$O(YSCLTLS("W",YSCLA)) Q:'YSCLA  S YSCLXWBC(YSCLA)="" D
     110  . S YSCLA1="" F  S YSCLA1=$O(RESULTS(YSCLA,YSCLA1)) Q:'YSCLA1  S YSCLYWBC(YSCLA1)=RESULTS(YSCLA,YSCLA1)_"^"_$P($G(^LAB(60,YSCLA,0)),"^")_"^"_YSCLTLS("W",YSCLA)
     111 S YSCLRWBC=$O(YSCLYWBC(0)) I 'YSCLRWBC D KILL Q "0^^^^^^"_YSCLFRQ
     112 S YSCLMULT=$P(YSCLYWBC(YSCLRWBC),"^",3),YSCLMULT=$S(YSCLMULT:1000,1:1)
     113 S YSCLRWBC(YSCLRWBC)=($P(YSCLYWBC(YSCLRWBC),"^")*YSCLMULT)_"^"_$P(YSCLYWBC(YSCLRWBC),"^",2)
     114 ;Scan for Neutrophil count on same day and time as most recent WBC
     115 S YSCLMTCH=0 F YSCLA="A","N","S","T" S YSCLTPT="" F  S YSCLTPT=$O(YSCLTLS(YSCLA,YSCLTPT)) Q:'YSCLTPT  D  Q:YSCLMTCH
     116  . S YSCLMULT=YSCLTLS(YSCLA,YSCLTPT),YSCLMULT=$S(YSCLMULT:1000,1:1)
     117  . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="A" S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=RESULTS(YSCLTPT,YSCLRWBC)*YSCLMULT_"^"_$P(^LAB(60,YSCLTPT,0),"^") Q
     118  . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="N" S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC))*.01)_"^"_$P(^LAB(60,YSCLTPT,0),"^") Q
     119  . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="S" D
     120  . . S YSCLSGS="" F  S YSCLSGS=$O(YSCLTLS("B",YSCLSGS)) D  Q:YSCLMTCH
     121  . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0
     122  . . . S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=YSCLRWBC(YSCLRWBC)*((RESULTS(YSCLTPT,YSCLRWBC)*.01)+(RESULTS(YSCLSGS,YSCLRWBC)*.01))_"^"_$P(^LAB(60,YSCLTPT,0),"^")_"/"_$P($G(^LAB(60,YSCLSGS,0)),"^") Q
     123  . I $D(RESULTS(YSCLTPT,YSCLRWBC)),YSCLA="C" D
     124  . . S YSCLSGS="" F  S YSCLSGS=$O(YSCLTLS("T",YSCLSGS)) D  Q:YSCLMTCH
     125  . . . S:'YSCLSGS YSCLSGS="Z" I '$D(RESULTS(YSCLSGS,YSCLRWBC)) S RESULTS(YSCLSGS,YSCLRWBC)=0
     126  . . . S YSCLMTCH=1,YSCLRANC(YSCLRWBC)=((RESULTS(YSCLTPT,YSCLRWBC)*YSCLMULT)+(RESULTS(YSCLSGS,YSCLRWBC)*YSCLMULT))_"^"_$P(^LAB(60,YSCLTPT,0),"^")_"/"_$P($G(^LAB(60,YSCLSGS,0)),"^") Q
     127 D KILL
     128 I $G(YSCLRWBC(YSCLRWBC))<3000!($G(YSCLRANC(YSCLRWBC))<1500) Q "0^"_$G(YSCLRWBC(YSCLRWBC))_"^"_$S($G(YSCLRANC(YSCLRWBC))="":"^",1:$G(YSCLRANC(YSCLRWBC)))_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ
     129 I $G(YSCLRWBC(YSCLRWBC))<3500!($G(YSCLRANC(YSCLRWBC))<2000) Q "2^"_$G(YSCLRWBC(YSCLRWBC))_"^"_$S($G(YSCLRANC(YSCLRWBC))="":"^",1:$G(YSCLRANC(YSCLRWBC)))_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ
     130 Q "1^"_YSCLRWBC(YSCLRWBC)_"^"_YSCLRANC(YSCLRWBC)_"^"_(9999999-YSCLRWBC)_"^"_YSCLFRQ
     131 ;
     132KILL ;
     133 K FDA,YSCLSGS,Y15,RESULTS,RESULTS1,YSCLA,YSCLA1,YSCLMTCH,YSCLSB1,YSCLSD,YSCLTA,YSCLMULT
     134 K YSCLTDT,YSCLTL,YSCLTLS,YSCLTPT,YSCLXWBC
     135 ;
     136OVERRIDE(DFN) ;Check to see if the NCCC has authorized an over-ride for today on this patient.
     137 S YSCLOVR=$O(^YSCL(603.01,"C",DFN,""))
     138 Q:YSCLOVR="" 0
     139 S YSCLOVR=$P(^YSCL(603.01,YSCLOVR,0),"^",4)
     140 Q YSCLOVR=DT
     141 ;
     142ZEOR ;YSCLTST2
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTALUSE.m

    r613 r623  
    1 YTALUSE ;ALB/ASF TEST-AUDIT ALCOHOL SCREEN ;4/30/97  09:25
    2         ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
    3 SCOR    ;
    4         S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
    5         S R=0 F I=1:1:8 S R=R+$E(X,I)
    6         S X1=$S($E(X,9)=1:2,$E(X,9)=2:4,1:0) S R=R+X1
    7         S X1=$S($E(X,10)=1:2,$E(X,10)=2:4,1:0) S R=R+X1
    8         D REPT^YTREPT
    9         W !!,"A score of 8 or more indicates a strong likelihood of hazardous",!,"or harmful alcohol consumption."
    10         QUIT
     1YTALUSE ;ALB/ASF TEST-AUDIT ALCOHOL SCREEN ;4/30/97  09:25
     2 ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
     3SCOR ;
     4 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
     5 S R=0 F I=1:1:8 S R=R+$E(X,I)
     6 S X1=$S($E(X,9)=1:2,$E(X,9)=2:4,1:0) S R=R+X1
     7 S X1=$S($E(X,10)=1:2,$E(X,10)=2:4,1:0) S R=R+X1
     8 D REPT^YTREPT
     9 W !!,"A score of 8 or more indicates a strong likelihood of hazardous",!,"or harmful alcohol consumption."
     10 QUIT
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m

    r613 r623  
    1 YTAPI5  ;ALB/ASF- MH API NOTES ; 7/24/07 4:11pm
    2         ;;5.01;MENTAL HEALTH;**62,85**;Dec 30, 1994;Build 49
    3         Q
    4 OUTNOTE(YSDATA) ;
    5         N G,I,N,P,R,X,Y,YS2,YSADATE,YSCODE,YSGG,YSGG1,YSGG2,YSJ,YSJJ,YSNCODE,YSSET,YSSR,YSST,YSX1,YSX2,YSX3,YIN,YSINN,YSINE,YSMC
    6         I $G(YSDATA(1))?1"[ERROR".E Q  ;---->
    7         I '$D(YSDATA(5)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad ysdata to outnote" Q  ;--->
    8         S YS2=$G(YSDATA(2))
    9         S YSCODE=$P(YS2,U,2)
    10         S YSADATE=$P(YS2,U,4)
    11         S YSNCODE=$O(^YTT(601,"B",YSCODE,-1))
    12         S YSX1=$P(YSDATA(3),U,2)
    13         S YSX2=$P(YSDATA(4),U,2)
    14         S YSX3=$P(YSDATA(5),U,2)
    15         S YSSR=$P(YSDATA(6),U,3)
    16         S YSST=$P(YSDATA(6),U,4)
    17         S Y=$G(^YTT(601.6,YSNCODE,2))
    18         I Y="" S YSDATA(1)="[ERROR]",YSDATA(2)="no mh mult outcome code" Q  ;--->
    19         ;
    20         X Y
    21         I X'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad M executable" Q  ;--->
    22 LD      ;LOAD NOTE
    23         S N=0
    24         F  S N=$O(^YTT(601.6,YSNCODE,3,X,1,N)) Q:N'>0  D
    25         . S YSDATA("ON",N,0)=^YTT(601.6,YSNCODE,3,X,1,N,0)
    26 REP     ;replace ||
    27         S N=0
    28         F  S N=$O(YSDATA("ON",N)) Q:N'>0  D
    29         . S G=YSDATA("ON",N,0)
    30         . S R=""
    31         . F I=1:1:$L(G,"|") D
    32         .. S P=$P(G,"|",I)
    33         .. D:P?1"RSCORE".1N.N RSCORE
    34         .. D:P?1"SSCORE".1N.N SSCORE
    35         .. D:P?1"ITEM".1N.E ITEM
    36         .. D:P?1"EXECUTE".E MC
    37         .. S R=R_P
    38         . S YSDATA("ON",N,0)=R
    39         Q
    40 RSCORE  ; raw scores
    41         S YSJ=$E(P,7,99),P=$P(YSDATA(YSJ+5),U,3)
    42         Q
    43 SSCORE  ;scaled score
    44         S YSJ=$E(P,7,99),P=$P(YSDATA(YSJ+5),U,4)
    45         Q
    46 ITEM    ;items resolution
    47         S YSIN=$E(P,5,999)
    48         S YSSET=$P(YSIN,";",2)
    49         S YSIN=$P(YSIN,";",1)
    50         S YSINN=$S(YSIN>400:5,YSIN>200:4,1:3)
    51         S YSINE=$S(YSIN#200=0:200,1:YSIN)
    52         S P=$P(YSDATA(YSINN),U,2)
    53         S P=$E(P,YSINE)
    54         Q:YSSET=""
    55         F YSJJ=1:1:$L(YSSET,",") D
    56         . S YSGG=$P(YSSET,",",YSJJ),YSGG1=$P(YSGG,":"),YSGG2=$P(YSGG,":",2)
    57         . S:P=YSGG1 P=YSGG2
    58         Q
    59 MC      ;mumps executable setting P
    60         S YSMC=$P(P,";",2)
    61         X YSMC
    62         Q
    63 GAFURL(YSDATA)  ;returns MH GAF horizontal sheet
    64         S YSDATA(1)="[DATA]"
    65         S YSDATA(2)="http://vaww.mentalhealth.med.va.gov/gafsheet.htm"
    66         Q
    67 PRIVL(YSDATA,YS)        ;check privileges
    68         N YSCODE,YSET
    69         S YSCODE=$G(YS("CODE"),-1)
    70         ;ASF 03/08/06
    71         I (YSCODE="GAF")!(YSCODE="ASI") S YSDATA(1)="[DATA]",YSDATA(2)="1^exempt test" Q  ;-->out test exempt
    72         I $D(^YTT(601.71,"B",YSCODE)) D  Q  ;--> out
    73         . S YSET=$O(^YTT(601.71,"B",YSCODE,0))
    74         . S YSDATA(1)="[DATA]"
    75         . S YSKEY=$$GET1^DIQ(601.71,YSET_",",9)
    76         . I YSKEY="" S YSDATA(2)="1^exempt test" Q  ;-->out
    77         . I $D(^XUSEC(YSKEY,DUZ)) S YSDATA(2)="1^user privileged" Q  ;-->out has key
    78         . S YSDATA(2)="0^no access" Q  ;->out
    79         ;
    80         I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD TEST CODE" Q  ;--> out
    81         S YSET=$O(^YTT(601,"B",YSCODE,0))
    82         S YSDATA(1)="[DATA]"
    83         I $D(^XUSEC("YSP",DUZ)) S YSDATA(2)="1^user privileged for all tests" Q  ;has key
    84         I $P(^YTT(601,YSET,0),U,10)="Y"!(YSCODE="GAF")!(YSCODE="ASI") S YSDATA(2)="1^exempt test" Q  ;test exempt
    85         I $P(^YTT(601,YSET,0),U,9)="I" S YSDATA(2)="1^interview" Q  ;interview
    86         S YSDATA(2)="0^no access"
    87         Q
     1YTAPI5 ;ALB/ASF- MH API NOTES ;3/17/00  14:54
     2 ;;5.01;MENTAL HEALTH;**62**;Dec 30, 1994
     3 Q
     4OUTNOTE(YSDATA) ;
     5 N G,I,N,P,R,X,Y,YS2,YSADATE,YSCODE,YSGG,YSGG1,YSGG2,YSJ,YSJJ,YSNCODE,YSSET,YSSR,YSST,YSX1,YSX2,YSX3,YIN,YSINN,YSINE,YSMC
     6 I $G(YSDATA(1))?1"[ERROR".E Q  ;---->
     7 I '$D(YSDATA(5)) S YSDATA(1)="ERROR]",YSDATA(2)="bad ysdata to outnote" Q  ;--->
     8 S YS2=$G(YSDATA(2))
     9 S YSCODE=$P(YS2,U,2)
     10 S YSADATE=$P(YS2,U,4)
     11 S YSNCODE=$O(^YTT(601,"B",YSCODE,-1))
     12 S YSX1=$P(YSDATA(3),U,2)
     13 S YSX2=$P(YSDATA(4),U,2)
     14 S YSX3=$P(YSDATA(5),U,2)
     15 S YSSR=$P(YSDATA(6),U,3)
     16 S YSST=$P(YSDATA(6),U,4)
     17 S Y=$G(^YTT(601.6,YSNCODE,2))
     18 I Y="" S YSDATA(1)="[ERROR"],YSDATA(2)="no mh mult outcome code" Q  ;--->
     19 ;
     20 X Y
     21 I X'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad M executable" Q  ;--->
     22LD ;LOAD NOTE
     23 S N=0
     24 F  S N=$O(^YTT(601.6,YSNCODE,3,X,1,N)) Q:N'>0  D
     25 . S YSDATA("ON",N,0)=^YTT(601.6,YSNCODE,3,X,1,N,0)
     26REP ;replace ||
     27 S N=0
     28 F  S N=$O(YSDATA("ON",N)) Q:N'>0  D
     29 . S G=YSDATA("ON",N,0)
     30 . S R=""
     31 . F I=1:1:$L(G,"|") D
     32 .. S P=$P(G,"|",I)
     33 .. D:P?1"RSCORE".1N.N RSCORE
     34 .. D:P?1"SSCORE".1N.N SSCORE
     35 .. D:P?1"ITEM".1N.E ITEM
     36 .. D:P?1"EXECUTE".E MC
     37 .. S R=R_P
     38 . S YSDATA("ON",N,0)=R
     39 Q
     40RSCORE ; raw scores
     41 S YSJ=$E(P,7,99),P=$P(YSDATA(YSJ+5),U,3)
     42 Q
     43SSCORE ;scaled score
     44 S YSJ=$E(P,7,99),P=$P(YSDATA(YSJ+5),U,4)
     45 Q
     46ITEM ;items resolution
     47 S YSIN=$E(P,5,999)
     48 S YSSET=$P(YSIN,";",2)
     49 S YSIN=$P(YSIN,";",1)
     50 S YSINN=$S(YSIN>400:5,YSIN>200:4,1:3)
     51 S YSINE=$S(YSIN#200=0:200,1:YSIN)
     52 S P=$P(YSDATA(YSINN),U,2)
     53 S P=$E(P,YSINE)
     54 Q:YSSET=""
     55 F YSJJ=1:1:$L(YSSET,",") D
     56 . S YSGG=$P(YSSET,",",YSJJ),YSGG1=$P(YSGG,":"),YSGG2=$P(YSGG,":",2)
     57 . S:P=YSGG1 P=YSGG2
     58 Q
     59MC ;mumps executable setting P
     60 S YSMC=$P(P,";",2)
     61 X YSMC
     62 Q
     63GAFURL(YSDATA) ;returns MH GAF horizontal sheet
     64 S YSDATA(1)="[DATA]"
     65 S YSDATA(2)="http://vaww.mentalhealth.med.va.gov/gafsheet.htm"
     66 Q
     67PRIVL(YSDATA,YS) ;check privileges
     68 N YSCODE,YSET
     69 S YSCODE=$G(YS("CODE"),-1)
     70 I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD TEST CODE" Q  ;--> out
     71 S YSET=$O(^YTT(601,"B",YSCODE,0))
     72 S YSDATA(1)="[DATA]"
     73 I $D(^XUSEC("YSP",DUZ)) S YSDATA(2)="1^user privileged for all tests" Q  ;has key
     74 I $P(^YTT(601,YSET,0),U,10)="Y"!(YSCODE="GAF")!(YSCODE="ASI") S YSDATA(2)="1^exempt test" Q  ;test exempt
     75 I $P(^YTT(601,YSET,0),U,9)="I" S YSDATA(2)="1^interview" Q  ;interview
     76 S YSDATA(2)="0^no access"
     77 Q
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m

    r613 r623  
    1 YTAUIRR ;ALB/ASF-   AUI-R REPORT ;11/15/90  16:58 ; 4/6/07 4:12pm
    2         ;;5.01;MENTAL HEALTH;**37,85**;Dec 30, 1994;Build 49
    3 F0      ;
    4         S R="",J=1
    5 T0      ;
    6         S L=200,M=0,YSKK=1,YSTL=0 G:'$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) STND D RD
    7 T1      ;
    8         I '$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) S R=R_YSTL_"^",J=J+1 G T0
    9         S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1
    10 T2      ;
    11         S YSIT=$P(Y,U,P) I YSIT="" S YSKK=YSKK+1 G T1
    12         S A=$P(Y,U,P+1),A=$A(A)-64,P=P+2
    13 T3      ;
    14         I +YSIT>L S L=L+200,M=M+200 D RD G T3
    15         S:$E(X,+YSIT-M)=A YSTL=YSTL+$P(YSIT,"(",2) G T2
    16 RD      ;
    17         S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q
    18 STND    ;
    19         S J=1,S=""
    20 LK      ;
    21         S A=$P(R,U,J) G:A="" REPT S L1=$P(^YTT(601,YSTEST,"S",J,"M"),U) I A<L1 S S=S_"0^",J=J+1 G LK
    22         I $D(^YTT(601,YSTEST,"S",J,"MS")) S L2=+^YTT(601,YSTEST,"S",J,"MS") I A'<L2 S S=S_$P(^YTT(601,YSTEST,"S",J,"MS"),U,A+2-L2),J=J+1 G LK
    23         S S=S_$P(^YTT(601,7,"S",J,"M"),U,A+2-L1)_"^",J=J+1 G LK
    24 REPT    ;
    25         Q:YSTY["X"  ;--> out ASF 09/15/04
    26         S X1="",$P(X1,"# ",60)=""
    27         S X=$P(^YTT(601,YSTEST,"P"),U),A=$P(^("P"),U,2),B=$P(^("P"),U,3),L1=58-A\2,L2=L1+A+4 S:A<9 A=9
    28         D DTA W !!?(72-$L(X)\2),X,!!!?4,"S C A L E",?22,"RAW   DECILE RANK"
    29         F J=1:1 S YSRS=$P(R,U,J) Q:YSRS=""  D:IOST?1"C-".E&($Y>21) SCR D H1:J=1,H5:J=5,H8:J=8,H13:J=13,H18:J=18,H24:J=24 W !?4,$P(^YTT(601,YSTEST,"S",J,0),U,2),?20,$J(YSRS,4,0),$J($P(S,U,J),5)," |",$E(X1,1,2*$P(S,U,J))
    30         Q
    31 IR      ;
    32         S P0=$S(IOST?1"P".E:1,1:0),K=0,YSLFT=0 F I=1:1 Q:'$D(^YTD(601.2,YSDFN,1,YSET,1,YSED,I))  S K=K+$L(^(I))
    33         S K=K\10+$Y D DTA S X=$P(^YTT(601,YSTEST,"P"),U) W !!?(72-$L(X)/2),X
    34         W !!!?25,"--- ITEM RESPONSES ---",!! S L=200,M=0,YSIT=1 I $D(^YTD(601.2,YSDFN,1,YSTEST,1,YSHD,99)),^(99)="MMPIR" S L=800
    35 R2      ;
    36         D RD S A=$L(X),B=A\10 I B S K=10 F I=1:1:B D RLN Q:YSLFT
    37         G:YSLFT DONE
    38         S K=-10*B+A I K D RLN G DONE
    39         G:A<200 DONE S L=L+200,M=M+200 I $D(^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200)) G R2
    40 DONE    ;
    41         K YSTY,X,Y,A,B,K,YSKK,L,L1,L2,M,J,YSIT,YSRS,I,P,YSMX,YSTL,YSTTL Q
    42 RLN     ;
    43         W ?1 F YSKK=1:1:K W $J(YSIT,3,0)," ",$E(X,YSIT-M),"  " S YSIT=YSIT+1
    44         D:'P0&($Y>21) SCR:I<B W ! Q
    45 SCR     ;
    46         ;  Added 5/6/94 LJA
    47         N A,B,B1,C,D,E,E1,F,F1,G,G1,H,I,J,J1,J2,J3,J4,K,L,L1,L2,M,N
    48         N N1,N2,N3,N4,P,P0,P1,P3,R,R1,S,S1,T,T1,T2,TT,V,V1,V2,V3
    49         N V4,V5,V6,W,X,X0,X1,X2,X3,X4,X7,X8,X9,Y,Y1,Y2,Z,Z1,Z3
    50         ;
    51         F I0=1:1:(IOSL-$Y-2) W !
    52         N DTOUT,DUOUT,DIRUT
    53         S DIR(0)="E" D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT),YSLFT=$D(DIRUT)
    54         W @IOF Q
    55 DTA     ;
    56         D KVAR^VADPT S DFN=YSDFN
    57         D DEM^VADPT,PID^VADPT
    58         S YSNM=VADM(1),YSSEX=$P(VADM(5),U),YSDOB=$P(VADM(3),U,2),YSAGE=VADM(4),YSSSN=VA("PID"),YSBID=VA("BID")
    59         D KVAR^VADPT
    60         S X0=^YTD(601.2,YSDFN,1,YSET,1,YSED,0),YSDTA=$P(X0,U,5) S:YSDTA'="" YSDTA=$$FMTE^XLFDT(YSDTA,"5ZD")
    61         S YSSX=YSSEX,YSBL="           ",YSHDR=YSSSN_"  "_YSNM_YSBL_YSBL_YSBL,YSHD=DT
    62         S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)_" "_YSDT(0)_" "_$$FMTE^XLFDT(YSHD,"5ZD") W @IOF,YSHDR," ",YSDTA
    63         S X=$P(^YTT(601,YSTEST,"P"),U)
    64         W ! S X7=$P(X0,U),X8=$P(X0,U,8) I X8,X8<X7 W "Begun: ",$$FMTE^XLFDT(X8,"5ZD"),"  Finished ",$$FMTE^XLFDT(X7,"5ZD")
    65         W ?53,"PRINTED  ENTERED  " W:YSDTA'="" "ADMIN" Q
    66 H1      ;
    67         W !,"PRIMARY SCALES",!?2,"Benefits" Q
    68 H5      ;
    69         W !!?2,"Styles" Q
    70 H8      ;
    71         W !!?2,"Consequences" Q
    72 H13     ;
    73         W !!?2,"Concerns and Acknowledgements" Q
    74 H18     ;
    75         W !!,"SECOND ORDER FACTOR SCALES" Q
    76 H24     ;
    77         W !!,"GENERAL ALCOHOL INVOLVEMENT SCALE" Q
     1YTAUIRR ;ALB/ASF-   AUI-R REPORT ;11/15/90  16:58 ;
     2 ;;5.01;MENTAL HEALTH;**37**;Dec 30, 1994
     3F0 ;
     4 S R="",J=1
     5T0 ;
     6 S L=200,M=0,YSKK=1,YSTL=0 G:'$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) STND D RD
     7T1 ;
     8 I '$D(^YTT(601,YSTEST,"S",J,"K",YSKK,0)) S R=R_YSTL_"^",J=J+1 G T0
     9 S Y=^YTT(601,YSTEST,"S",J,"K",YSKK,0),P=1
     10T2 ;
     11 S YSIT=$P(Y,U,P) I YSIT="" S YSKK=YSKK+1 G T1
     12 S A=$P(Y,U,P+1),A=$A(A)-64,P=P+2
     13T3 ;
     14 I +YSIT>L S L=L+200,M=M+200 D RD G T3
     15 S:$E(X,+YSIT-M)=A YSTL=YSTL+$P(YSIT,"(",2) G T2
     16RD ;
     17 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200) Q
     18STND ;
     19 S J=1,S=""
     20LK ;
     21 S A=$P(R,U,J) G:A="" REPT S L1=$P(^YTT(601,YSTEST,"S",J,"M"),U) I A<L1 S S=S_"0^",J=J+1 G LK
     22 I $D(^YTT(601,YSTEST,"S",J,"MS")) S L2=+^YTT(601,YSTEST,"S",J,"MS") I A'<L2 S S=S_$P(^YTT(601,YSTEST,"S",J,"MS"),U,A+2-L2),J=J+1 G LK
     23 S S=S_$P(^YTT(601,7,"S",J,"M"),U,A+2-L1)_"^",J=J+1 G LK
     24REPT ;
     25 S X1="",$P(X1,"# ",60)=""
     26 S X=$P(^YTT(601,YSTEST,"P"),U),A=$P(^("P"),U,2),B=$P(^("P"),U,3),L1=58-A\2,L2=L1+A+4 S:A<9 A=9
     27 D DTA W !!?(72-$L(X)\2),X,!!!?4,"S C A L E",?22,"RAW   DECILE RANK"
     28 F J=1:1 S YSRS=$P(R,U,J) Q:YSRS=""  D:IOST?1"C-".E&($Y>21) SCR D H1:J=1,H5:J=5,H8:J=8,H13:J=13,H18:J=18,H24:J=24 W !?4,$P(^YTT(601,YSTEST,"S",J,0),U,2),?20,$J(YSRS,4,0),$J($P(S,U,J),5)," |",$E(X1,1,2*$P(S,U,J))
     29 Q
     30IR ;
     31 S P0=$S(IOST?1"P".E:1,1:0),K=0,YSLFT=0 F I=1:1 Q:'$D(^YTD(601.2,YSDFN,1,YSET,1,YSED,I))  S K=K+$L(^(I))
     32 S K=K\10+$Y D DTA S X=$P(^YTT(601,YSTEST,"P"),U) W !!?(72-$L(X)/2),X
     33 W !!!?25,"--- ITEM RESPONSES ---",!! S L=200,M=0,YSIT=1 I $D(^YTD(601.2,YSDFN,1,YSTEST,1,YSHD,99)),^(99)="MMPIR" S L=800
     34R2 ;
     35 D RD S A=$L(X),B=A\10 I B S K=10 F I=1:1:B D RLN Q:YSLFT
     36 G:YSLFT DONE
     37 S K=-10*B+A I K D RLN G DONE
     38 G:A<200 DONE S L=L+200,M=M+200 I $D(^YTD(601.2,YSDFN,1,YSET,1,YSED,L\200)) G R2
     39DONE ;
     40 K YSTY,X,Y,A,B,K,YSKK,L,L1,L2,M,J,YSIT,YSRS,I,P,YSMX,YSTL,YSTTL Q
     41RLN ;
     42 W ?1 F YSKK=1:1:K W $J(YSIT,3,0)," ",$E(X,YSIT-M),"  " S YSIT=YSIT+1
     43 D:'P0&($Y>21) SCR:I<B W ! Q
     44SCR ;
     45 ;  Added 5/6/94 LJA
     46 N A,B,B1,C,D,E,E1,F,F1,G,G1,H,I,J,J1,J2,J3,J4,K,L,L1,L2,M,N
     47 N N1,N2,N3,N4,P,P0,P1,P3,R,R1,S,S1,T,T1,T2,TT,V,V1,V2,V3
     48 N V4,V5,V6,W,X,X0,X1,X2,X3,X4,X7,X8,X9,Y,Y1,Y2,Z,Z1,Z3
     49 ;
     50 F I0=1:1:(IOSL-$Y-2) W !
     51 N DTOUT,DUOUT,DIRUT
     52 S DIR(0)="E" D ^DIR K DIR S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT),YSLFT=$D(DIRUT)
     53 W @IOF Q
     54DTA ;
     55 S X0=^YTD(601.2,YSDFN,1,YSET,1,YSED,0),YSDTA=$P(X0,U,5) S:YSDTA'="" YSDTA=$$FMTE^XLFDT(YSDTA,"5ZD")
     56 S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)_" "_YSDT(0)_" "_$$FMTE^XLFDT(YSHD,"5ZD") W @IOF,YSHDR," ",YSDTA
     57 W ! S X7=$P(X0,U),X8=$P(X0,U,8) I X8,X8<X7 W "Begun: ",$$FMTE^XLFDT(X8,"5ZD"),"  Finished ",$$FMTE^XLFDT(X7,"5ZD")
     58 W ?53,"PRINTED  ENTERED  " W:YSDTA'="" "ADMIN" Q
     59H1 ;
     60 W !,"PRIMARY SCALES",!?2,"Benefits" Q
     61H5 ;
     62 W !!?2,"Styles" Q
     63H8 ;
     64 W !!?2,"Consequences" Q
     65H13 ;
     66 W !!?2,"Concerns and Acknowledgements" Q
     67H18 ;
     68 W !!,"SECOND ORDER FACTOR SCALES" Q
     69H24 ;
     70 W !!,"GENERAL ALCOHOL INVOLVEMENT SCALE" Q
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR.m

    r613 r623  
    1 YTDOMR  ;ALB/ASF-DEPRESSION OUTCOME MODULE REPORT ; 5/7/07 10:39am
    2         ;;5.01;MENTAL HEALTH;**31,85**;Dec 30, 1994;Build 49
    3 EN81    ;
    4         D ^YTDOMR1
    5         S (YSCR,YSDEP,YSPA,YSPB,YSSEV,YSNOT)=0
    6         S R=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
    7         ;PART A SAD-NOFUN
    8         I $E(R,49)>2!($E(R,50)>2) S YSPA=1
    9         ;PART B DEPRESSIVE SYMPTOMS 4 WEEKS
    10         I $E(R,49)>2 S YSCR=YSCR+1
    11         I $E(R,50)>2 S YSCR=YSCR+1
    12         I $E(R,51)>2!($E(R,52)>2) S YSCR=YSCR+1
    13         I $E(R,53)>2 S YSCR=YSCR+1
    14         I $E(R,54)>2 S YSCR=YSCR+1
    15         I $E(R,55)>2 S YSCR=YSCR+1
    16         I $E(R,56)>2 S YSCR=YSCR+1
    17         I $E(R,57)>2 S YSCR=YSCR+1
    18         I $E(R,58)>2!($E(R,59)="Y") S YSCR=YSCR+1
    19         I YSCR>4 S YSPB=1
    20         ;MISSING
    21         S YSMISS=$L($E(R,49,59),"X")-1
    22         I ((YSCR<5)&((YSMISS+YSCR)>4))!(YSMISS>4) S YSPB=""
    23         I YSPA,YSPB S YSDEP=1
    24         I YSPB="" S YSDEP=""
    25         I $E(R,25)="Y" S YSNOT=1
    26         F I=49:1:59 S X=$E(R,I) S X=$S(X="Y":3,X="N":0,X?1N:X-1,1:0) S YSSEV=YSSEV+X
    27         S YSSEV=YSSEV/(11-YSMISS)*33.33
    28         I YSMISS>1 S YSSEV=""
    29 OUT81   ;
    30         S I1="",$P(I1,"_",79)="" W !!,I1
    31         W !,"Scoring: By self report,"
    32         W:YSDEP'="" !,"The patient "_$S(YSDEP:"DOES",1:"DOES NOT")_" meet DSM IV Criterion A for Major Depressive Episode."
    33         W:YSDEP="" !,"Diagnosis not available due to "_YTMISS_" missing items"
    34         I YSNOT W !,"However a recent death is reported."
    35         W !?15,"DOM severity score= "
    36         W $S(YSSEV="":" not scoreable due to missing items",1:$J(YSSEV,3,0))
    37         W !,"There are no normative data for interpreting the severity score, but changes"
    38         W !,"between this score and the score on the DOM Patient Follow-Up Assessment",!,"(Form 8.3) may reflect changes in the severity of the patient's symptoms."
    39         W !,I1
    40         Q
    41 EN82    ;
    42         D ^YTDOMR1
    43         S (YSCR,YSDEP,YSPA,YSPB,YSSEV,YSNOT)=0
    44         S R=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
    45         I $E(R,4)="Y"!($E(R,5)="Y") S YSPA=1
    46         F I=4:1:12 S:$E(R,I)="Y" YSCR=YSCR+1
    47         S:YSCR>4 YSPB=1
    48         I YSPA&YSPB S YSDEP=1
    49         F I=13,14,15,18,20,21,22 S:$E(R,I)="Y" YSNOT=1
    50         ;
    51 OUT82   ;
    52         S I1="",$P(I1,"_",79)="" W !!,I1
    53         W !,"Scoring:"
    54         S X=$E(R,1)
    55         W !,"Clinician reports: "
    56         W $S(X=1:"MAJOR DEPRESSION (SINGLE EPISODE OR RECURRENT)",X=2:"Mood Disorder secondary to a general medical condition",X=3:"Posttraumatic Stress Disorder",X=4:"Substance use disorder(s)",X=5:"NO MAJOR DEPRESSION",1:"??")
    57         W !,"The patient "_$S(YSDEP:"DOES",1:"DOES NOT")_" meet DSM IV criteria for major depression."
    58         I YSNOT W !,"However exclusionary features are reported."
    59         W !,I1
    60         Q
    61 EN80    ;
    62         D ^YTDOMR1
    63         S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
    64         S X1=0
    65         S:$E(X,1)="Y" X1=1
    66         S:($E(X,2)="Y")&($E(X,3)="Y")&($E(X,4)>1) X1=1
    67         W:(X1=1) !!,"This screen is positive, and the possibility of a mood disorder",!,"should be evaluated further."
    68         W:(X1=0) !!,"This screen for mood disorder is negative."
    69         Q
    70 ENG     ;geriatric screen
    71         S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)
    72         W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
    73         W !,?53,"PRINTED",?64,"ENTERED",!
    74         W !!,?3,"*** Geriatric Depression Screen ***",!!
    75         W !,"The patient was questioned about mood in the past week.",!
    76         W !,"Felt could not shake off blues: " S YSI=1 D ENGQ
    77         W !,"Felt depressed: " S YSI=2 D ENGQ
    78         W !,"Felt fearful: " S YSI=3 D ENGQ
    79         W !,"Sleep was restless: " S YSI=4 D ENGQ
    80         W !,"Felt hopeless about the future: " S YSI=5 D ENGQ
    81         S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
    82         S (YSMISS,YSDEP)=0 F I=1:1:4 S YSDEP=YSDEP+$E(X,I) S:$E(X,I)="X" YSMISS=YSMISS+1 ; ASF 10/20/06
    83         S:$E(X,5)?1N YSDEP=YSDEP+(3-$E(X,5)) S:$E(X,5)="X" YSMISS=YSMISS+1
    84         I YSMISS=1 S YSDEP=YSDEP+(YSDEP/4)
    85         I YSMISS>1 W !!,"The validity of this test is compromised as "_YSMISS_" of the 5 questions",!,"were not answered." Q
    86         W !!,"Score: "_YSDEP
    87         W:(YSDEP>3.9) !,"This screen is positive, and the possibility of a mood disorder",!,"should be evaluated further."
    88         W:(YSDEP<4) !,"This screen for mood disorder is negative."
    89         Q
    90 ENGQ    ;
    91         S Y1=$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),YSI)
    92         I YSI<5 W $S(Y1=0:"rarely",Y1=1:"some of the time",Y1=2:"much of the time",Y1=3:"most of the time",1:"question not answered")
    93         I YSI=5 W $S(Y1=3:"rarely",Y1=2:"some of the time",Y1=1:"much of the time",Y1=0:"most of the time",1:"question not answered")
     1YTDOMR ;ALB/ASF-DEPRESSION OUTCOME MODULE REPORT ;2/23/99  15:09
     2 ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
     3EN81 ;
     4 D ^YTDOMR1
     5 S (YSCR,YSDEP,YSPA,YSPB,YSSEV,YSNOT)=0
     6 S R=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
     7 ;PART A SAD-NOFUN
     8 I $E(R,49)>2!($E(R,50)>2) S YSPA=1
     9 ;PART B DEPRESSIVE SYMPTOMS 4 WEEKS
     10 I $E(R,49)>2 S YSCR=YSCR+1
     11 I $E(R,50)>2 S YSCR=YSCR+1
     12 I $E(R,51)>2!($E(R,52)>2) S YSCR=YSCR+1
     13 I $E(R,53)>2 S YSCR=YSCR+1
     14 I $E(R,54)>2 S YSCR=YSCR+1
     15 I $E(R,55)>2 S YSCR=YSCR+1
     16 I $E(R,56)>2 S YSCR=YSCR+1
     17 I $E(R,57)>2 S YSCR=YSCR+1
     18 I $E(R,58)>2!($E(R,59)="Y") S YSCR=YSCR+1
     19 I YSCR>4 S YSPB=1
     20 ;MISSING
     21 S YSMISS=$L($E(R,49,59),"X")-1
     22 I ((YSCR<5)&((YSMISS+YSCR)>4))!(YSMISS>4) S YSPB=""
     23 I YSPA,YSPB S YSDEP=1
     24 I YSPB="" S YSDEP=""
     25 I $E(R,25)="Y" S YSNOT=1
     26 F I=49:1:59 S X=$E(R,I) S X=$S(X="Y":3,X="N":0,X?1N:X-1,1:0) S YSSEV=YSSEV+X
     27 S YSSEV=YSSEV/(11-YSMISS)*33.33
     28 I YSMISS>1 S YSSEV=""
     29OUT81 ;
     30 S I1="",$P(I1,"_",79)="" W !!,I1
     31 W !,"Scoring: By self report,"
     32 W:YSDEP'="" !,"The patient "_$S(YSDEP:"DOES",1:"DOES NOT")_" meet DSM IV Criterion A for Major Depressive Episode."
     33 W:YSDEP="" !,"Diagnosis not available due to "_YTMISS_" missing items"
     34 I YSNOT W !,"However a recent death is reported."
     35 W !?15,"DOM severity score= "
     36 W $S(YSSEV="":" not scoreable due to missing items",1:$J(YSSEV,3,0))
     37 W !,"There are no normative data for interpreting the severity score, but changes"
     38 W !,"between this score and the score on the DOM Patient Follow-Up Assessment",!,"(Form 8.3) may reflect changes in the severity of the patient's symptoms."
     39 W !,I1
     40 Q
     41EN82 ;
     42 D ^YTDOMR1
     43 S (YSCR,YSDEP,YSPA,YSPB,YSSEV,YSNOT)=0
     44 S R=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1)
     45 I $E(R,4)="Y"!($E(R,5)="Y") S YSPA=1
     46 F I=4:1:12 S:$E(R,I)="Y" YSCR=YSCR+1
     47 S:YSCR>4 YSPB=1
     48 I YSPA&YSPB S YSDEP=1
     49 F I=13,14,15,18,20,21,22 S:$E(R,I)="Y" YSNOT=1
     50 ;
     51OUT82 ;
     52 S I1="",$P(I1,"_",79)="" W !!,I1
     53 W !,"Scoring:"
     54 S X=$E(R,1)
     55 W !,"Clinician reports: "
     56 W $S(X=1:"MAJOR DEPRESSION (SINGLE EPISODE OR RECURRENT)",X=2:"Mood Disorder secondary to a general medical condition",X=3:"Posttraumatic Stress Disorder",X=4:"Substance use disorder(s)",X=5:"NO MAJOR DEPRESSION",1:"??")
     57 W !,"The patient "_$S(YSDEP:"DOES",1:"DOES NOT")_" meet DSM IV criteria for major depression."
     58 I YSNOT W !,"However exclusionary features are reported."
     59 W !,I1
     60 Q
     61EN80 ;
     62 D ^YTDOMR1
     63 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
     64 S X1=0
     65 S:$E(X,1)="Y" X1=1
     66 S:($E(X,2)="Y")&($E(X,3)="Y")&($E(X,4)>1) X1=1
     67 W:(X1=1) !!,"This screen is positive, and the possibility of a mood disorder",!,"should be evaluated further."
     68 W:(X1=0) !!,"This screen for mood disorder is negative."
     69 Q
     70ENG ;geriatric screen
     71 S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)
     72 W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
     73 W !,?53,"PRINTED",?64,"ENTERED",!
     74 W !!,?3,"*** Geriatric Depression Screen ***",!!
     75 W !,"The patient was questioned about mood in the past week.",!
     76 W !,"Felt could not shake off blues: " S YSI=1 D ENGQ
     77 W !,"Felt depressed: " S YSI=2 D ENGQ
     78 W !,"Felt fearful: " S YSI=3 D ENGQ
     79 W !,"Sleep was restless: " S YSI=4 D ENGQ
     80 W !,"Felt hopeful about the future: " S YSI=5 D ENGQ
     81 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
     82 S (YSMISS,YSDEP)=0 F I=1:1:5 S YSDEP=YSDEP+$E(X,I) S:$E(X,I)="X" YSMISS=YSMISS+1
     83 I YSMISS=1 S YSDEP=YSDEP+(YSDEP/4)
     84 I YSMISS>1 W !!,"The validity of this test is compromised as "_YSMISS_" of the 5 questions",!,"were not answered." Q
     85 W !!,"Score: "_YSDEP
     86 W:(YSDEP>3.9) !,"This screen is positive, and the possibility of a mood disorder",!,"should be evaluated further."
     87 W:(YSDEP<4) !,"This screen for mood disorder is negative."
     88 Q
     89ENGQ ;
     90 S Y1=$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),YSI)
     91 I YSI<5 W $S(Y1=0:"rarely",Y1=1:"some of the time",Y1=2:"much of the time",Y1=3:"most of the time",1:"question not answered")
     92 I YSI=5 W $S(Y1=3:"rarely",Y1=2:"some of the time",Y1=1:"much of the time",Y1=0:"most of the time",1:"question not answered")
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR1.m

    r613 r623  
    1 YTDOMR1 ;ALB/ASF SLC/DKG-EXTENDED INTERVIEW REPORTER ;6/19/97  17:09
    2         ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
    3         ;
    4 MAIN    ;
    5         K ^UTILITY($J,"W")
    6         S YSLFN=1 ; S YSJ=1,U1=0,L=-200,YSLCK=200
    7         D R1
    8         D PRT
    9         Q
    10 R1      ;
    11         F YSJ=1:1 Q:'$D(^YTT(601,YSTEST,"G",1,1,YSJ,0))  D R2
    12         Q
    13 R2      ;
    14         S A=^YTT(601,YSTEST,"G",1,1,YSJ,0),YSITEM=+$P(A,U),YSEXE=$P($P(A,U),";",2)
    15         I YSITEM=0 S R="" X YSEXE D STEM Q
    16         I YSEXE="L"!(YSEXE="'L") D LISTER Q
    17         S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
    18         S R=$E(YSYX,YSITEM-L) Q:R=" "!(R="X")
    19         S:"YN"[R R=R="N"+1 S R=$P(A,U,R+2) Q:R=""
    20         D STEM
    21         Q
    22 STEM    ;
    23         S YSSTEM=$P(A,U,2)
    24         I YSSTEM'["#" S YSYTX=YSSTEM_R D L Q
    25         S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,999) D L Q
    26         S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,999) D L
    27         Q
    28 END     ;
    29         K I,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q
    30 LISTER  ;list formated output
    31         K B1 S YSTL=0,YSTLN=1,YSCOMP=$S(YSEXE="'L":"N",1:"Y")
    32         ; check at list begining
    33         S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) I YSQTYP'=1 S R="eRROR LINE "_YSJ D STEM Q
    34         S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
    35         S R=$E(YSYX,YSITEM-L)
    36         S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,3)
    37         D LIST1
    38         I 'YSTL S R=$P(A,U,YSTLN+2) D STEM Q
    39         I YSTL=1 S R=B1(1) D STEM Q
    40         I YSTL=2  S R=B1(1)_" and "_B1(2) D STEM Q
    41         S R="" F I=1:1:YSTL-1 S R=R_B1(I)_", "
    42         S R=R_"and "_B1(YSTL) D STEM
    43         Q
    44 LIST1   S YSTLN=YSTLN+1,YSITEM=YSITEM+1
    45         Q:'$D(^YTT(601,YSTEST,"Q",YSITEM))
    46         S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) Q:YSQTYP'=2
    47         S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
    48         S R=$E(YSYX,YSITEM-L)
    49         S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,YSTLN+2)
    50         G LIST1
    51 L       ;
    52         D:YSYTX["{" PRO ;evaluate pronouns etc
    53         I $L(YSYTX)<80 S DIWL=0,DIWR=79,X=YSYTX D ^DIWP
    54         I $L(YSYTX)>80 D
    55         . S YSX1=YSYTX
    56         . F I=$L(YSX1):-1:1 S Y1=$E(YSX1,I) I Y1=" "&(I<80) S X=$E(YSX1,1,I-1),YSX1=$E(YSX1,I+1,999),DIWL=0,DIWR=79 D ^DIWP Q
    57         . I $L(YSX1),YSX1'=" " S DIWL=0,DIWR=79,X=YSX1 D ^DIWP
    58         Q
    59 PRT     ; Print output
    60         S YSZZ=0
    61         S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)
    62         W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
    63         W !,?53,"PRINTED",?64,"ENTERED",!
    64         S N=0 F  S N=$O(^UTILITY($J,"W",0,N)) Q:N'>0!YSZZ  D
    65         . W !,^UTILITY($J,"W",0,N,0)
    66         . D:$Y+4>IOSL WAIT
    67         ;
    68         Q
    69 WAIT    ;
    70         F I0=1:1:IOSL-$Y-2 W !
    71         N DTOUT,DUOUT,DIRUT
    72         I IOST?1"C".E W $C(7) S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT)
    73         Q:YSZZ
    74         W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
    75         W !?53,"PRINTED",?64,"ENTERED",!
    76         Q
    77 PRO     ;evaluate pronoun, possesive etc
    78         F I=1:1:$L(YSYTX,"{") D
    79         . S P1=$F(YSYTX,"{")-1,P2=$F(YSYTX,"}")
    80         . Q:'P1!'P2
    81         . S G=$E(YSYTX,P1+1,P2-2),G1=0
    82         . S:G="Pro" G1=$S(YSSEX="F":"She",1:"He")
    83         . S:G="pro" G1=$S(YSSEX="F":"she",1:"he")
    84         . S:G="Pos" G1=$S(YSSEX="F":"Her",1:"His")
    85         . S:G="pos" G1=$S(YSSEX="F":"her",1:"his")
    86         . S:G="Title" G1=$S(YSSEX="F":"Ms.",1:"Mr.")
    87         . S:G="DATE" G1=$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3)
    88         . S:G="CLIN" G1=$P($G(^VA(200,$P(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3),20)),U,2)
    89         . I G="Last" S X=$P($P(^DPT(YSDFN,0),U),",") D
    90         .. F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999)
    91         .. S G1=X
    92         . S YSYTX=$E(YSYTX,1,P1-1)_G1_$E(YSYTX,P2,999)
    93         ;
    94         Q
     1YTDOMR1 ;ALB/ASF SLC/DKG-EXTENDED INTERVIEW REPORTER ;6/19/97  17:09
     2 ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
     3 ;
     4MAIN ;
     5 K ^UTILITY($J,"W")
     6 S YSLFN=1 ; S YSJ=1,U1=0,L=-200,YSLCK=200
     7 D R1
     8 D PRT
     9 Q
     10R1 ;
     11 F YSJ=1:1 Q:'$D(^YTT(601,YSTEST,"G",1,1,YSJ,0))  D R2
     12 Q
     13R2 ;
     14 S A=^YTT(601,YSTEST,"G",1,1,YSJ,0),YSITEM=+$P(A,U),YSEXE=$P($P(A,U),";",2)
     15 I YSITEM=0 S R="" X YSEXE D STEM Q
     16 I YSEXE="L"!(YSEXE="'L") D LISTER Q
     17 S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
     18 S R=$E(YSYX,YSITEM-L) Q:R=" "!(R="X")
     19 S:"YN"[R R=R="N"+1 S R=$P(A,U,R+2) Q:R=""
     20 D STEM
     21 Q
     22STEM ;
     23 S YSSTEM=$P(A,U,2)
     24 I YSSTEM'["#" S YSYTX=YSSTEM_R D L Q
     25 S A=$F(YSSTEM,"#") I A<3 S YSYTX=R_$E(YSSTEM,2,999) D L Q
     26 S YSYTX=$E(YSSTEM,1,A-2)_R_$E(YSSTEM,A,999) D L
     27 Q
     28END ;
     29 K I,YSLCK,R,YSSTEM,YSYX,YSYCK,YSSCK Q
     30LISTER ;list formated output
     31 K B1 S YSTL=0,YSTLN=1,YSCOMP=$S(YSEXE="'L":"N",1:"Y")
     32 ; check at list begining
     33 S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) I YSQTYP'=1 S R="eRROR LINE "_YSJ D STEM Q
     34 S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
     35 S R=$E(YSYX,YSITEM-L)
     36 S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,3)
     37 D LIST1
     38 I 'YSTL S R=$P(A,U,YSTLN+2) D STEM Q
     39 I YSTL=1 S R=B1(1) D STEM Q
     40 I YSTL=2  S R=B1(1)_" and "_B1(2) D STEM Q
     41 S R="" F I=1:1:YSTL-1 S R=R_B1(I)_", "
     42 S R=R_"and "_B1(YSTL) D STEM
     43 Q
     44LIST1 S YSTLN=YSTLN+1,YSITEM=YSITEM+1
     45 Q:'$D(^YTT(601,YSTEST,"Q",YSITEM))
     46 S YSQTYP=^YTT(601,YSTEST,"Q",YSITEM,1) Q:YSQTYP'=2
     47 S L=(YSITEM-1)\200*200,U1=L+200,YSYX=^YTD(601.2,YSDFN,1,YSET,1,YSED,U1\200)
     48 S R=$E(YSYX,YSITEM-L)
     49 S:R=YSCOMP YSTL=YSTL+1,B1(YSTL)=$P(A,U,YSTLN+2)
     50 G LIST1
     51L ;
     52 D:YSYTX["{" PRO ;evaluate pronouns etc
     53 I $L(YSYTX)<80 S DIWL=0,DIWR=79,X=YSYTX D ^DIWP
     54 I $L(YSYTX)>80 D
     55 . S YSX1=YSYTX
     56 . F I=$L(YSX1):-1:1 S Y1=$E(YSX1,I) I Y1=" "&(I<80) S X=$E(YSX1,1,I-1),YSX1=$E(YSX1,I+1,999),DIWL=0,DIWR=79 D ^DIWP Q
     57 . I $L(YSX1),YSX1'=" " S DIWL=0,DIWR=79,X=YSX1 D ^DIWP
     58 Q
     59PRT ; Print output
     60 S YSZZ=0
     61 S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)
     62 W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
     63 W !,?53,"PRINTED",?64,"ENTERED",!
     64 S N=0 F  S N=$O(^UTILITY($J,"W",0,N)) Q:N'>0!YSZZ  D
     65 . W !,^UTILITY($J,"W",0,N,0)
     66 . D:$Y+4>IOSL WAIT
     67 ;
     68 Q
     69WAIT ;
     70 F I0=1:1:IOSL-$Y-2 W !
     71 N DTOUT,DUOUT,DIRUT
     72 I IOST?1"C".E W $C(7) S DIR(0)="E" D ^DIR K DIR S YSZZ=$D(DIRUT)
     73 Q:YSZZ
     74 W @IOF,YSHDR,?53,$$FMTE^XLFDT(DT,"5ZD"),?64,$$FMTE^XLFDT(YSHD,"5ZD")
     75 W !?53,"PRINTED",?64,"ENTERED",!
     76 Q
     77PRO ;evaluate pronoun, possesive etc
     78 F I=1:1:$L(YSYTX,"{") D
     79 . S P1=$F(YSYTX,"{")-1,P2=$F(YSYTX,"}")
     80 . Q:'P1!'P2
     81 . S G=$E(YSYTX,P1+1,P2-2),G1=0
     82 . S:G="Pro" G1=$S(YSSEX="F":"She",1:"He")
     83 . S:G="pro" G1=$S(YSSEX="F":"she",1:"he")
     84 . S:G="Pos" G1=$S(YSSEX="F":"Her",1:"His")
     85 . S:G="pos" G1=$S(YSSEX="F":"her",1:"his")
     86 . S:G="Title" G1=$S(YSSEX="F":"Ms.",1:"Mr.")
     87 . S:G="DATE" G1=$E(YSED,4,5)_"/"_$E(YSED,6,7)_"/"_$E(YSED,2,3)
     88 . S:G="CLIN" G1=$P($G(^VA(200,$P(^YTD(601.2,YSDFN,1,YSET,1,YSED,0),U,3),20)),U,2)
     89 . I G="Last" S X=$P($P(^DPT(YSDFN,0),U),",") D
     90 .. F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999)
     91 .. S G1=X
     92 . S YSYTX=$E(YSYTX,1,P1-1)_G1_$E(YSYTX,P2,999)
     93 ;
     94 Q
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m

    r613 r623  
    1 YTKIL   ;SLC/TGA-KILL TEST/INTERVIEW DATA ;4/21/92  08:50 ; 10/31/07 12:41pm
    2         ;;5.01;MENTAL HEALTH;**37,85**;Dec 30, 1994;Build 49
    3         ;
    4         ; Called from the top by MENU option YSMKIL
    5         ;
    6         S YSO=0,YSNOKILL=1 W @IOF,!!,"Delete Patient Data"
    7         W ! D ^YSLRP G:YSDFN<1 END
    8         S DIR(0)="Y",DIR("A")="Delete MHA3 data",DIR("B")="No" D ^DIR
    9         Q:$G(DIRUT)
    10         IF Y D EN^YTQKIL Q  ;-->out
    11         I '$D(^YTD(601.2,YSDFN)),'$D(^YTD(601.4,YSDFN)) W !!,"NO DATA ON THIS PATIENT!" G END
    12 R       ;
    13         R !!,"Delete All tests and interviews? N// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT END S A=$TR($E(A_"N"),"yn","YN") I "YN"'[A W:A'["?" " ?",$C(7) G R
    14         I "Y"[A S DIK="^YTD(601.2,",DA=YSDFN D ^DIK S DIK="^YTD(601.4,",DA=YSDFN D ^DIK W !!,"DELETED!" G END
    15         S T(0)=0 G:'$O(^YTD(601.4,YSDFN,1,0)) C W !!,"Incomplete tests and Interviews",! S YTC=$O(^YTT(601,"B","CLERK",0))
    16         S T=0
    17         F  S T=$O(^YTD(601.4,YSDFN,1,T)) G:'T C S T(0)=T(0)+1 G:YSTOUT!YSUOUT END S X=^(T,0),P=$P(X,U),D=$P(X,U,2),DA=P S:P=YTC P=$P(X,U,6),DA=YTC W !!,$$TN(+YSDFN,+T,+P),?10,$$FMTE^XLFDT(D,"5ZD") D DI
    18 DI      ;
    19         R " ...Delete? N// ",K:DTIME S YSTOUT='$T,YSUOUT=K["^",K=$E(K) Q:"Nn"[K  I YSTOUT!YSUOUT Q
    20         I "Yy"'[K W:K'["?" " ?",$C(7) G DI
    21         S DIK="^YTD(601.4,YSDFN,1,",DA(1)=YSDFN D ^DIK W ?40,"DELETED!" Q
    22 C       ;
    23         G:'$D(^YTD(601.2,YSDFN,1,0)) E W !!,"Completed Tests and Interviews"
    24         S T=0
    25         F  S T=$O(^YTD(601.2,YSDFN,1,T)) G:'T!YSUOUT END F D=0:0 S D=$O(^YTD(601.2,YSDFN,1,T,1,D)) Q:'D  S T(0)=T(0)+1 Q:YSTOUT!YSUOUT  Q:'$D(^YTT(601,T))  W !!,$P(^YTT(601,T,0),U),?10,$$FMTE^XLFDT(D,"5ZD") D DC
    26 DC      ;
    27         R " ...Delete? N// ",K:DTIME S YSTOUT='$T,YSUOUT=K["^",K=$E(K) Q:"Nn"[K  I YSTOUT!YSUOUT Q
    28         I "Yy"'[K W:K'["?" " ?",$C(7) G DC
    29         S DIK="^YTD(601.2,YSDFN,1,T,1,",DA=D,DA(1)=T,DA(2)=YSDFN D ^DIK W ?40,"DELETED" Q
    30 E       ;
    31         W:'T(0) !!,"NO TESTS/INTERVIEWS FOUND!"
    32 END     ;
    33         K %,A,D,DA,DIC,DIK,K,P,T,X,YSAGE,YSDFN,YSDOB,YSE,YSN,YSNM,YSNOKILL,YSO,YSS,YSSEX,YSSSN,YTC
    34         QUIT
    35         ;
    36 TN(DFN,TN6014,TN601)    ;Print test name...
    37         ; TN6014 = IEN of ^YTD(601.4,+DFN,1,+TN6014...
    38         ; TN601  = IEN of ^YTT(601,+TN601...
    39         N TESTNAME,X
    40         S X=$P($G(^YTT(601,+TN601,0)),U),TESTNAME=$S(X']"":"Unknown",1:X)
    41         I $G(^YTD(601.4,+DFN,1,+TN6014,99))'="MMPIR" QUIT TESTNAME ;->
    42         QUIT $S(TN601=60:"MMPIR",TN601=61:"MMPR",1:"Unknown") ;->
    43         ;
     1YTKIL ;SLC/TGA-KILL TEST/INTERVIEW DATA ;4/21/92  08:50 ;03/11/94 12:49
     2 ;;5.01;MENTAL HEALTH;**37**;Dec 30, 1994
     3 ;
     4 ; Called from the top by MENU option YSMKIL
     5 ;
     6 S YSO=0,YSNOKILL=1 W @IOF,!!,"Delete Patient Data"
     7 W ! D ^YSLRP G:YSDFN<1 END I '$D(^YTD(601.2,YSDFN)),'$D(^YTD(601.4,YSDFN)) W !!,"NO DATA ON THIS PATIENT!" G END
     8R ;
     9 R !!,"Delete All tests and interviews? N// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT END S A=$TR($E(A_"N"),"yn","YN") I "YN"'[A W:A'["?" " ?",$C(7) G R
     10 I "Y"[A S DIK="^YTD(601.2,",DA=YSDFN D ^DIK S DIK="^YTD(601.4,",DA=YSDFN D ^DIK W !!,"DELETED!" G END
     11 S T(0)=0 G:'$O(^YTD(601.4,YSDFN,1,0)) C W !!,"Incomplete tests and Interviews",! S YTC=$O(^YTT(601,"B","CLERK",0))
     12 S T=0
     13 F  S T=$O(^YTD(601.4,YSDFN,1,T)) G:'T C S T(0)=T(0)+1 G:YSTOUT!YSUOUT END S X=^(T,0),P=$P(X,U),D=$P(X,U,2),DA=P S:P=YTC P=$P(X,U,6),DA=YTC W !!,$$TN(+YSDFN,+T,+P),?10,$$FMTE^XLFDT(D,"5ZD") D DI
     14DI ;
     15 R " ...Delete? N// ",K:DTIME S YSTOUT='$T,YSUOUT=K["^",K=$E(K) Q:"Nn"[K  I YSTOUT!YSUOUT Q
     16 I "Yy"'[K W:K'["?" " ?",$C(7) G DI
     17 S DIK="^YTD(601.4,YSDFN,1,",DA(1)=YSDFN D ^DIK W ?40,"DELETED!" Q
     18C ;
     19 G:'$D(^YTD(601.2,YSDFN,1,0)) E W !!,"Completed Tests and Interviews"
     20 S T=0
     21 F  S T=$O(^YTD(601.2,YSDFN,1,T)) G:'T!YSUOUT END F D=0:0 S D=$O(^YTD(601.2,YSDFN,1,T,1,D)) Q:'D  S T(0)=T(0)+1 Q:YSTOUT!YSUOUT  Q:'$D(^YTT(601,T))  W !!,$P(^YTT(601,T,0),U),?10,$$FMTE^XLFDT(D,"5ZD") D DC
     22DC ;
     23 R " ...Delete? N// ",K:DTIME S YSTOUT='$T,YSUOUT=K["^",K=$E(K) Q:"Nn"[K  I YSTOUT!YSUOUT Q
     24 I "Yy"'[K W:K'["?" " ?",$C(7) G DC
     25 S DIK="^YTD(601.2,YSDFN,1,T,1,",DA=D,DA(1)=T,DA(2)=YSDFN D ^DIK W ?40,"DELETED" Q
     26E ;
     27 W:'T(0) !!,"NO TESTS/INTERVIEWS FOUND!"
     28END ;
     29 K %,A,D,DA,DIC,DIK,K,P,T,X,YSAGE,YSDFN,YSDOB,YSE,YSN,YSNM,YSNOKILL,YSO,YSS,YSSEX,YSSSN,YTC
     30 QUIT
     31 ;
     32TN(DFN,TN6014,TN601) ;Print test name...
     33 ; TN6014 = IEN of ^YTD(601.4,+DFN,1,+TN6014...
     34 ; TN601  = IEN of ^YTT(601,+TN601...
     35 N TESTNAME,X
     36 S X=$P($G(^YTT(601,+TN601,0)),U),TESTNAME=$S(X']"":"Unknown",1:X)
     37 I $G(^YTD(601.4,+DFN,1,+TN6014,99))'="MMPIR" QUIT TESTNAME ;->
     38 QUIT $S(TN601=60:"MMPIR",TN601=61:"MMPR",1:"Unknown") ;->
     39 ;
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTMMPI2B.m

    r613 r623  
    1 YTMMPI2B        ;ALB/ASF-MMPI2 HARRIS:LINGOS,CRIT,OS ;11/4/98  16:25
    2         ;;5.01;MENTAL HEALTH;**10,31**;Dec 30, 1994
    3 SCOR    ;
    4         S (R,S)="" F J=44:1:84 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
    5         K A,YSTVL S YSSCALE=S,YSRAW=R
    6         D HL,WAIT:IOST?1"C-".E Q:YSLFT
    7         D SI Q:YSLFT
    8         D OS,WAIT:IOST?1"C-".E Q:YSLFT
    9         D NEWSC,WAIT:IOST?1"C".E Q:YSLFT
    10         ;I $D(^YTT(601,YSTEST,"S",107)) D ^YTMMPI2D,WAIT:IOST?1"C-".E Q:YSLFT
    11         D CRIT,WAIT:IOST?1"C-".E Q:YSLFT  D:(X(0)["X")!(X(1)["X")!(X(2)["X") OMIT,WAIT:IOST?1"C-".E Q:YSLFT  D NK^YTMMPI2P Q
    12 HL      ;HARRIS LINGOS
    13         D DTA^YTREPT W !!!?25,"Harris-Lingoes Subscales",!?10,"(to be used as an aid in interpreting the parent scale)",!!?50,"Raw Score",?65,"T Score"
    14         F J=44:1:71 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) D:YSN?.E1"1".E HLPARNT W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL&(IOST?1"C-".E) WAIT Q:YSLFT
    15         Q
    16 HLPARNT ;
    17         W:J'=44 !! W !,$S(J=44:"Depression",J=49:"Hysteria",J=54:"Psychopathic Deviate",J=59:"Paranoia",J=62:"Schizophrenia",1:"Hypomania")," Subscales",! Q
    18 WAIT    ;
    19         I IOST'?1"C-".E D DTA^YTREPT Q
    20         ; %%  ANOTHER READER CALL ???? LOOK YSLFT = YSTOUT %%%
    21         W $C(7) R YSLFT:DTIME S YSTOUT='$T,YSUOUT=YSLFT["^"
    22         S:YSLFT["^"!'$T YSLFT=1 Q:YSLFT  S Z1=1 W # Q
    23 SI      ;
    24         D DTA^YTREPT W !!!?25,"Social Introversion Subscales",!?18,"(Ben-Porath, Hostetler, Butcher, and Graham)",!!?50,"Raw Score",?65,"T Score"
    25         F J=72:1:74 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT
    26         Q
    27 OS      ;OBVIOUS SUBTLE
    28         W !!!!?25,"Wiener-Harmon Subtle-Obvious Subscales",!!?50,"Raw Score",?65,"T Score"
    29         F J=75:1:84 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT
    30         S S=$P(YSSCALE,U,32,41) W !!?3,"Total T Score Difference (Obvious-Subtle): ",$P(S,U)+$P(S,U,3)+$P(S,U,5)+$P(S,U,7)+$P(S,U,9)-$P(S,U,2)-$P(S,U,4)-$P(S,U,6)-$P(S,U,8)-$P(S,U,10)
    31         Q
    32 NEWSC   ;scales AAS,AAP,marital,fp S,hostility
    33         Q:'$D(^YTT(601,YSTEST,"S",107))
    34         W !!?25,"Additional Supplementary Scales",!
    35         S (R,S)="" F J=107:1:112 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
    36         K A,YSTVL S YSSCALE=S,YSRAW=R
    37         F J=107:1:112 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-106),S=$P(YSSCALE,U,J-106) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT
    38         W !!!!,"Uniform T scores are used for HS, D, Hy, Pd, Pa, Pt, Sc, Ma, and",!,"the Content Scales; all other MMPI-2 scales use linear T scores.",!! Q
    39 CRIT    ;CRITICAL ITEMS
    40         D DTA^YTREPT W !?25,"Critical Items",!! S N=0 F I=1:1 S N=$O(^YTT(601,YSTEST,"G",1,1,N)) Q:'N  W !,^(N,0)
    41         S YSCNT=0 F J=85,88,86,89,87,90 D CRIT1 Q:YSLFT
    42         Q:YSLFT  W !!!,YSCNT," Koss-Butcher Critical Items were endorsed."
    43         S YSCNT=0 F J=91:1:100,106 D CRIT1 Q:YSLFT
    44         Q:YSLFT  W !!!,YSCNT," Lachar-Wrobel Critical Items were endorsed."
    45         Q
    46 CRIT1   ;
    47         S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),YSKY=$S($D(^YTT(601,YSTEST,"S",J,YSSX_"K")):^(YSSX_"K"),1:^YTT(601,YSTEST,"S",J,"K",1,0))
    48         I $D(^YTT(601,YSTEST,"S",J,"K",2,0)) S YSKY=YSKY_^(0)
    49         S X(0)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1),X(1)=^(2),X(2)=^(3) D:$Y+4>IOSL WAIT Q:YSLFT  W !!!,YSN,!
    50         F I=1:2 S YSIT=$P(YSKY,U,I) Q:YSIT'?1N.N  S B=$P(YSKY,U,I+1) I $E(X(YSIT\200),YSIT#200)=B S YSCNT=YSCNT+1 D L,WAIT:$Y+4>IOSL
    51         Q
    52 L       W !,$J(YSIT,5),". " F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",YSIT,"T",K))  W:K'=1 !?7 W ^YTT(601,YSTEST,"Q",YSIT,"T",K,0)
    53         W:B'="X" " (",B,")" Q
    54 OMIT    ;OMITTED ITEMS
    55         D DTA^YTREPT W !!!?25,"OMITTED ITEMS",!!!,"The following items were omitted by the client.  It may be helpful to",!,"discuss these items with this individual to determine the reason",!,"for non-compliance with test instructions.",!!!
    56         S B="X" F I=0,1,2 I X(I)["X" F J=1:1:$L(X(I)) I $E(X(I),J)="X" S YSIT=J+(200*I) D L
    57         D WAIT Q
    58 VV      ;
    59         S N=0 F  S N=$O(^YTT(601,202,"S",N)) Q:'N  S G=^(N,0) W !,N,?5,$P(G,U),?10,$P(G,U,2)
     1YTMMPI2B ;ALB/ASF-MMPI2 HARRIS:LINGOS,CRIT,OS ;6/19/03  14:43
     2 ;;5.01;MENTAL HEALTH;**10,31,76,70**;Dec 30, 1994
     3SCOR ;
     4 S (R,S)="" F J=44:1:84 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
     5 K A,YSTVL S YSSCALE=S,YSRAW=R
     6 D HL,WAIT:IOST?1"C-".E Q:YSLFT
     7 D SI Q:YSLFT
     8 ;D OS,WAIT:IOST?1"C-".E Q:YSLFT
     9 D NEWSC,WAIT:(IOST?1"C".E)&($Y+4>IOSL) Q:YSLFT
     10 D PSY5,WAIT:(IOST?1"C".E)&($Y+4>IOSL) Q:YSLFT
     11 D RCCLIN,WAIT:IOST?1"C".E Q:YSLFT
     12 ;I $D(^YTT(601,YSTEST,"S",107)) D ^YTMMPI2D,WAIT:IOST?1"C-".E Q:YSLFT
     13 D CRIT,WAIT:IOST?1"C-".E Q:YSLFT  D:(X(0)["X")!(X(1)["X")!(X(2)["X") OMIT,WAIT:IOST?1"C-".E Q:YSLFT  D NK^YTMMPI2P Q
     14HL ;HARRIS LINGOS
     15 D DTA^YTREPT W !!!?25,"Harris-Lingoes Subscales",!?10,"(to be used as an aid in interpreting the parent scale)",!!?50,"Raw Score",?65,"T Score"
     16 F J=44:1:71 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) D:YSN?.E1"1".E HLPARNT W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL&(IOST?1"C-".E) WAIT Q:YSLFT
     17 Q
     18HLPARNT ;
     19 W:J'=44 !! W !,$S(J=44:"Depression",J=49:"Hysteria",J=54:"Psychopathic Deviate",J=59:"Paranoia",J=62:"Schizophrenia",1:"Hypomania")," Subscales",! Q
     20WAIT ;
     21 I IOST'?1"C-".E D DTA^YTREPT Q
     22 ; %%  ANOTHER READER CALL ???? LOOK YSLFT = YSTOUT %%%
     23 W $C(7) R YSLFT:DTIME S YSTOUT='$T,YSUOUT=YSLFT["^"
     24 S:YSLFT["^"!'$T YSLFT=1 Q:YSLFT  S Z1=1 W # Q
     25SI ;
     26 D DTA^YTREPT W !!!?25,"Social Introversion Subscales",!?18,"(Ben-Porath, Hostetler, Butcher, and Graham)",!!?50,"Raw Score",?65,"T Score"
     27 F J=72:1:74 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT
     28 Q
     29OS ;OBVIOUS SUBTLE
     30 W !!!!?25,"Wiener-Harmon Subtle-Obvious Subscales",!!?50,"Raw Score",?65,"T Score"
     31 F J=75:1:84 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-43),S=$P(YSSCALE,U,J-43) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT
     32 S S=$P(YSSCALE,U,32,41) W !!?3,"Total T Score Difference (Obvious-Subtle): ",$P(S,U)+$P(S,U,3)+$P(S,U,5)+$P(S,U,7)+$P(S,U,9)-$P(S,U,2)-$P(S,U,4)-$P(S,U,6)-$P(S,U,8)-$P(S,U,10)
     33 Q
     34NEWSC ;scales AAS,AAP,marital,fp S,hostility
     35 Q:'$D(^YTT(601,YSTEST,"S",107))
     36 W !!?25,"Additional Supplementary Scales",!
     37 S (R,S)="" F J=107:1:112 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
     38 K A,YSTVL S YSSCALE=S,YSRAW=R
     39 F J=107:1:112 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-106),S=$P(YSSCALE,U,J-106) W !?3,$E($P(YSN," ",2,9),1,36)," (",$P(YSN," "),")",?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT
     40 W !!,"Uniform T scores are used for HS, D, Hy, Pd, Pa, Pt, Sc, Ma, and",!,"the Content Scales; all other MMPI-2 scales use linear T scores.",! Q
     41PSY5 ; ADDED 8/30/02 ASF
     42 Q:'$D(^YTT(601,YSTEST,"S",114))
     43 W !?25,"PSY-5 Personality Psychopathology Five",!?50,"Raw Score",?65,"T Score"
     44 S (R,S)="" F J=114:1:118 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
     45 K A,YSTVL S YSSCALE=S,YSRAW=R
     46 F J=114:1:118 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-113),S=$P(YSSCALE,U,J-113) W !?3,YSN,?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT
     47 Q
     48RCCLIN ;restructured clinical
     49 Q:$G(^YTT(601,YSTEST,"S",119,0))'?.E1"RC".E
     50 W !!?25,"RC Restructured Clinical Scales",!?50,"Raw Score",?65,"T Score"
     51 S (R,S)="" F J=119:1:127 D T0^YTMMPI2A S P=YSSX D LK^YTMMPI2A
     52 K A,YSTVL S YSSCALE=S,YSRAW=R
     53 F J=119:1:127 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),R=$P(YSRAW,U,J-118),S=$P(YSSCALE,U,J-118) W !?3,YSN,?50,$J(R,4),?65,$J(S,4) D:$Y+4>IOSL WAIT Q:YSLFT
     54 Q
     55CRIT ;CRITICAL ITEMS
     56 D DTA^YTREPT W !?25,"Critical Items",!! S N=0 F I=1:1 S N=$O(^YTT(601,YSTEST,"G",1,1,N)) Q:'N  W !,^(N,0)
     57 S YSCNT=0 F J=85,88,86,89,87,90 D CRIT1 Q:YSLFT
     58 Q:YSLFT  W !!!,YSCNT," Koss-Butcher Critical Items were endorsed."
     59 S YSCNT=0 F J=91:1:100,106 D CRIT1 Q:YSLFT
     60 Q:YSLFT  W !!!,YSCNT," Lachar-Wrobel Critical Items were endorsed."
     61 Q
     62CRIT1 ;
     63 S YSN=$P(^YTT(601,YSTEST,"S",J,0),U,2),YSKY=$S($D(^YTT(601,YSTEST,"S",J,YSSX_"K")):^(YSSX_"K"),1:^YTT(601,YSTEST,"S",J,"K",1,0))
     64 I $D(^YTT(601,YSTEST,"S",J,"K",2,0)) S YSKY=YSKY_^(0)
     65 S X(0)=^YTD(601.2,YSDFN,1,YSTEST,1,YSED,1),X(1)=^(2),X(2)=^(3) D:$Y+4>IOSL WAIT Q:YSLFT  W !!!,YSN,!
     66 F I=1:2 S YSIT=$P(YSKY,U,I) Q:YSIT'?1N.N  S B=$P(YSKY,U,I+1) I $E(X(YSIT\200),YSIT#200)=B S YSCNT=YSCNT+1 D L,WAIT:$Y+4>IOSL
     67 Q
     68L W !,$J(YSIT,5),". " F K=1:1 Q:'$D(^YTT(601,YSTEST,"Q",YSIT,"T",K))  W:K'=1 !?7 W ^YTT(601,YSTEST,"Q",YSIT,"T",K,0)
     69 W:B'="X" " (",B,")" Q
     70OMIT ;OMITTED ITEMS
     71 D DTA^YTREPT W !!!?25,"OMITTED ITEMS",!!!,"The following items were omitted by the client.  It may be helpful to",!,"discuss these items with this individual to determine the reason",!,"for non-compliance with test instructions.",!!!
     72 S B="X" F I=0,1,2 I X(I)["X" F J=1:1:$L(X(I)) I $E(X(I),J)="X" S YSIT=J+(200*I) D L
     73 D WAIT Q
     74VV ;
     75 S N=0 F  S N=$O(^YTT(601,202,"S",N)) Q:'N  S G=^(N,0) W !,N,?5,$P(G,U),?10,$P(G,U,2)
  • WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m

    r613 r623  
    1 YTPCL   ;ALB/ASF TEST-PTST CHECKLISTS ; 4/5/07 10:05am
    2         ;;5.01;MENTAL HEALTH;**66,85**;Dec 30, 1994;Build 49
    3         ;
    4         ;Reference to ^DIR supported by IA #10026
    5         ;
    6 SCOR    ;
    7         S YSTY="W*",YSNOITEM="DONE^YTPCL"
    8         D ^YTREPT
    9         S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
    10         S (B,C,D)=0
    11         F I=1:1:5 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) B=B+1
    12         F I=6:1:12 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) C=C+1
    13         F I=13:1:17 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) D=D+1
    14 ZZ      W !!,"DSM-IV PTSD Criteria B ",$S(B>0:"IS met",1:"is NOT met")
    15         W !,"DSM-IV PTSD Criteria C ",$S(C>2:"IS met",1:"is NOT met")
    16         W !,"DSM-IV PTSD Criteria D ",$S(D>1:"IS met",1:"is NOT met")
    17         I (B>0)&(C>2)&(D>1) W !!,"*** PTSD Diagnosis IS SUGGESTED ***"
    18         W !!
    19         I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1
    20         W !!!,"Items"
    21         F I=1:1:17 D
    22         . W !,I,". ",^YTT(601,YSET,"Q",I,"T",1,0)
    23         . I $D(^YTT(601,YSET,"Q",I,"T",2,0)) W:^(0)'=" " !?7,^(0)
    24         . I I=5 W !?7,^YTT(601,YSET,"Q",I,"T",3,0)
    25         . W " :",$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),I)
    26         W !!,"1= Not at all 2= A little bit 3= Moderately 4= Quite a bit 5= Extremely"
    27         Q
    28 SPTSD   ;SCREENING REPORT
    29         D DTA^YTREPT
    30         W !!,?7,"Post Traumatic Stress Disorder Screen",!!
    31         S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
    32         W !,"Patient Reports "_$S($E(X,1)="Y":"HAVING",1:"NO")_" traumatic experiences.",!
    33         W:$E(X,2)="Y" !,"In the past month, the patient has been bothered by repeated, disturbing",!,"memories, thoughts, or images of one or more of the stressful events."
    34         W:$E(X,3)="Y" !,"In the past month, has felt distant or cut off from other people."
    35         W:$E(X,4)="Y" !,"Has been 'super alert' or watchful or on guard in the past month."
    36         W:$E(X,2,9)?.E1"Y".E !!,"Please refer to a mental health professional for further evaluation",!,"and treatment of probable PTSD"
    37         I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1
    38 DONE    QUIT
     1YTPCL ;ALB/ASF TEST-PTST CHECKLISTS ;7/19/00  11:11
     2 ;;5.01;MENTAL HEALTH;**66**;Dec 30, 1994
     3 ;
     4 ;Reference to ^DIR supported by IA #10026
     5 ;
     6SCOR ;
     7 S YSTY="W*",YSNOITEM="DONE^YTPCL"
     8 D ^YTREPT
     9 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
     10 S (B,C,D)=0
     11 F I=1:1:5 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) B=B+1
     12 F I=6:1:12 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) C=C+1
     13 F I=13:1:17 S Y=$E(X,I) S:(Y=3)!(Y=4)!(Y=5) D=D+1
     14ZZ W !!,"DSM-IV PTSD Criteria B ",$S(B>0:"IS met",1:"is NOT met")
     15 W !,"DSM-IV PTSD Criteria C ",$S(C>2:"IS met",1:"is NOT met")
     16 W !,"DSM-IV PTSD Criteria D ",$S(D>1:"IS met",1:"is NOT met")
     17 I (B>0)&(C>2)&(D>1) W !!,"*** PTSD Diagnosis IS SUGGESTED ***"
     18 W !!
     19 I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1
     20 D IR^YTREPT
     21 Q
     22SPTSD ;SCREENING REPORT
     23 D DTA^YTREPT
     24 W !!,?7,"Post Traumatic Stress Disorder Screen",!!
     25 S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
     26 W !,"Patient Reports "_$S($E(X,1)="Y":"HAVING",1:"NO")_" traumatic experiences.",!
     27 W:$E(X,2)="Y" !,"In the past month, the patient has been bothered by repeated, disturbing",!,"memories, thoughts, or images of one or more of the stressful events."
     28 W:$E(X,3)="Y" !,"In the past month, has felt distant or cut off from other people."
     29 W:$E(X,4)="Y" !,"Has been 'super alert' or watchful or on guard in the past month."
     30 W:$E(X,2,9)?.E1"Y".E !!,"Please refer to a mental health professional for further evaluation",!,"and treatment of probable PTSD"
     31 I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1
     32DONE QUIT
Note: See TracChangeset for help on using the changeset viewer.