SD53589P ;BP/DMR POST INIT ROUTINE
;;5.3;Scheduling;**589**;Aug 13, 1993;Build 41
;
;Populate file MH PCMM STOP CODES (#404.61).
;
INIT ;Set temp global
S ^TMP("SD53589P",$J,524)="ACTIVE DUTY SEXUAL TRAUMA"
S ^TMP("SD53589P",$J,445)="C&P VIA CVT PROV SITE^YES"
S ^TMP("SD53589P",$J,444)="C&P VIA CVT PT SITE^YES"
S ^TMP("SD53589P",$J,450)="COMP & PENS (C&P) EXAMS^YES"
S ^TMP("SD53589P",$J,554)="DAY HOSPITAL-GROUP"
S ^TMP("SD53589P",$J,506)="DAY HOSPITAL-INDIVIDUAL"
S ^TMP("SD53589P",$J,553)="DAY TREATMENT-GROUP"
S ^TMP("SD53589P",$J,505)="DAY TREATMENT-INDIVIDUAL"
S ^TMP("SD53589P",$J,448)="DES EXAM^YES"
S ^TMP("SD53589P",$J,504)="GRANT & PER DIEM GROUP"
S ^TMP("SD53589P",$J,511)="GRANT & PER DIEM INDIV"
S ^TMP("SD53589P",$J,508)="HCHV/HCMI GROUP"
S ^TMP("SD53589P",$J,529)="HCHV/HCMI INDIV"
S ^TMP("SD53589P",$J,507)="HUD/VASH GROUP"
S ^TMP("SD53589P",$J,522)="HUD/VASH INDIV"
S ^TMP("SD53589P",$J,447)="IDES VIA CVT PROV SITE^YES"
S ^TMP("SD53589P",$J,446)="IDES VIA CVT PT SITE^YES"
S ^TMP("SD53589P",$J,547)="INTNSE SUB USE DSRDER GRP"
S ^TMP("SD53589P",$J,548)="INTNSE SUB USE DSRDER IND"
S ^TMP("SD53589P",$J,502)="MENTAL HEALTH CLINIC - IND"
S ^TMP("SD53589P",$J,550)="MENTAL HEALTH CLINIC-GROUP"
S ^TMP("SD53589P",$J,568)="MH CWT/SE FACE TO FACE"
S ^TMP("SD53589P",$J,574)="MH CWT/TWE FACE TO FACE"
S ^TMP("SD53589P",$J,573)="MH INCENTIVE THERAPY F TO F"
S ^TMP("SD53589P",$J,503)="MH RESIDENTIAL CARE IND"
S ^TMP("SD53589P",$J,535)="MH VOCATIONAL ASSISTANCE - IND"
S ^TMP("SD53589P",$J,575)="MH VOCATIONAL ASSISTANCE-GRP"
S ^TMP("SD53589P",$J,567)="MHICM - GROUP"
S ^TMP("SD53589P",$J,552)="MHICM - INDIVIDUAL"
S ^TMP("SD53589P",$J,373)="MOVE! PGM GROUP^YES"
S ^TMP("SD53589P",$J,372)="MOVE! PGM INDIV^YES"
S ^TMP("SD53589P",$J,523)="OPIOID SUBSTITUTION"
S ^TMP("SD53589P",$J,561)="PCT-POST TRAUMATIC STRESS-GRP"
S ^TMP("SD53589P",$J,583)="PRRC GROUP"
S ^TMP("SD53589P",$J,582)="PRRC INDIVIDUAL"
S ^TMP("SD53589P",$J,557)="PSYCHIATRY - GROUP"
S ^TMP("SD53589P",$J,509)="PSYCHIATRY - INDIVIDUAL"
S ^TMP("SD53589P",$J,577)="PSYCHOGERIATRIC - GROUP"
S ^TMP("SD53589P",$J,576)="PSYCHOGERIATRIC - INDIVIDUAL"
S ^TMP("SD53589P",$J,558)="PSYCHOLOGY-GROUP"
S ^TMP("SD53589P",$J,510)="PSYCHOLOGY-INDIVIDUAL"
S ^TMP("SD53589P",$J,516)="PTSD - GROUP"
S ^TMP("SD53589P",$J,562)="PTSD - INDIVIDUAL"
S ^TMP("SD53589P",$J,540)="PTSD CLINICAL TEAM PTS IND"
S ^TMP("SD53589P",$J,580)="PTSD DAY HOSPITAL"
S ^TMP("SD53589P",$J,596)="RRTP ADMISSION SCREENING SRVCS"
S ^TMP("SD53589P",$J,595)="RRTP AFTERCARE GRP"
S ^TMP("SD53589P",$J,588)="RRTP AFTERCARE IND"
S ^TMP("SD53589P",$J,598)="RRTP PRE-ADMIT IND"
S ^TMP("SD53589P",$J,572)="SERV-MH GROUP"
S ^TMP("SD53589P",$J,571)="SERV-MH INDIVIDUAL"
S ^TMP("SD53589P",$J,707)="SMOKING CESSATION^YES"
S ^TMP("SD53589P",$J,514)="SUB USE DISORDER HOME VST"
S ^TMP("SD53589P",$J,519)="SUBST USE DISORDER/PTSD TEAMS"
S ^TMP("SD53589P",$J,513)="SUBSTANCE USE DISORDER IND"
S ^TMP("SD53589P",$J,560)="SUBSTANCE USE DISORDR GRP"
S ^TMP("SD53589P",$J,708)="TELE SMOKE CESS PROV SITE^YES"
S ^TMP("SD53589P",$J,525)="WOMEN'S STRESS DISORDER TEAMS"
;
D START
S $P(^SCTM(404.61,0),"^",3)=CC
S $P(^SCTM(404.61,0),"^",4)=CC
D EXIT
Q
;
START ;
;
S (IEN,SC,CC,REC)=""
S SC="" F S SC=$O(^TMP("SD53589P",$J,SC)) Q:SC="" D
.S IEN="" F S IEN=$O(^DIC(40.7,"C",SC,IEN)) Q:IEN="" D
..Q:$$GET1^DIQ(40.7,IEN,2)'=""
..S CC=CC+1 S REC=""
..I $P(^TMP("SD53589P",$J,SC),"^",2)="YES" D
...S ^SCTM(404.61,CC,0)=IEN_"^"_1 S REC=1
...S ^SCTM(404.61,"AC",1,CC)=""
..I REC="" S ^SCTM(404.61,CC,0)=IEN
..S ^SCTM(404.61,"B",IEN,CC)=""
Q
;
EXIT ;
K IEN,CC,SC,REC
K ^TMP("SD53589P",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53589P 3769 printed Dec 13, 2024@02:45:16 Page 2
SD53589P ;BP/DMR POST INIT ROUTINE
+1 ;;5.3;Scheduling;**589**;Aug 13, 1993;Build 41
+2 ;
+3 ;Populate file MH PCMM STOP CODES (#404.61).
+4 ;
INIT ;Set temp global
+1 SET ^TMP("SD53589P",$JOB,524)="ACTIVE DUTY SEXUAL TRAUMA"
+2 SET ^TMP("SD53589P",$JOB,445)="C&P VIA CVT PROV SITE^YES"
+3 SET ^TMP("SD53589P",$JOB,444)="C&P VIA CVT PT SITE^YES"
+4 SET ^TMP("SD53589P",$JOB,450)="COMP & PENS (C&P) EXAMS^YES"
+5 SET ^TMP("SD53589P",$JOB,554)="DAY HOSPITAL-GROUP"
+6 SET ^TMP("SD53589P",$JOB,506)="DAY HOSPITAL-INDIVIDUAL"
+7 SET ^TMP("SD53589P",$JOB,553)="DAY TREATMENT-GROUP"
+8 SET ^TMP("SD53589P",$JOB,505)="DAY TREATMENT-INDIVIDUAL"
+9 SET ^TMP("SD53589P",$JOB,448)="DES EXAM^YES"
+10 SET ^TMP("SD53589P",$JOB,504)="GRANT & PER DIEM GROUP"
+11 SET ^TMP("SD53589P",$JOB,511)="GRANT & PER DIEM INDIV"
+12 SET ^TMP("SD53589P",$JOB,508)="HCHV/HCMI GROUP"
+13 SET ^TMP("SD53589P",$JOB,529)="HCHV/HCMI INDIV"
+14 SET ^TMP("SD53589P",$JOB,507)="HUD/VASH GROUP"
+15 SET ^TMP("SD53589P",$JOB,522)="HUD/VASH INDIV"
+16 SET ^TMP("SD53589P",$JOB,447)="IDES VIA CVT PROV SITE^YES"
+17 SET ^TMP("SD53589P",$JOB,446)="IDES VIA CVT PT SITE^YES"
+18 SET ^TMP("SD53589P",$JOB,547)="INTNSE SUB USE DSRDER GRP"
+19 SET ^TMP("SD53589P",$JOB,548)="INTNSE SUB USE DSRDER IND"
+20 SET ^TMP("SD53589P",$JOB,502)="MENTAL HEALTH CLINIC - IND"
+21 SET ^TMP("SD53589P",$JOB,550)="MENTAL HEALTH CLINIC-GROUP"
+22 SET ^TMP("SD53589P",$JOB,568)="MH CWT/SE FACE TO FACE"
+23 SET ^TMP("SD53589P",$JOB,574)="MH CWT/TWE FACE TO FACE"
+24 SET ^TMP("SD53589P",$JOB,573)="MH INCENTIVE THERAPY F TO F"
+25 SET ^TMP("SD53589P",$JOB,503)="MH RESIDENTIAL CARE IND"
+26 SET ^TMP("SD53589P",$JOB,535)="MH VOCATIONAL ASSISTANCE - IND"
+27 SET ^TMP("SD53589P",$JOB,575)="MH VOCATIONAL ASSISTANCE-GRP"
+28 SET ^TMP("SD53589P",$JOB,567)="MHICM - GROUP"
+29 SET ^TMP("SD53589P",$JOB,552)="MHICM - INDIVIDUAL"
+30 SET ^TMP("SD53589P",$JOB,373)="MOVE! PGM GROUP^YES"
+31 SET ^TMP("SD53589P",$JOB,372)="MOVE! PGM INDIV^YES"
+32 SET ^TMP("SD53589P",$JOB,523)="OPIOID SUBSTITUTION"
+33 SET ^TMP("SD53589P",$JOB,561)="PCT-POST TRAUMATIC STRESS-GRP"
+34 SET ^TMP("SD53589P",$JOB,583)="PRRC GROUP"
+35 SET ^TMP("SD53589P",$JOB,582)="PRRC INDIVIDUAL"
+36 SET ^TMP("SD53589P",$JOB,557)="PSYCHIATRY - GROUP"
+37 SET ^TMP("SD53589P",$JOB,509)="PSYCHIATRY - INDIVIDUAL"
+38 SET ^TMP("SD53589P",$JOB,577)="PSYCHOGERIATRIC - GROUP"
+39 SET ^TMP("SD53589P",$JOB,576)="PSYCHOGERIATRIC - INDIVIDUAL"
+40 SET ^TMP("SD53589P",$JOB,558)="PSYCHOLOGY-GROUP"
+41 SET ^TMP("SD53589P",$JOB,510)="PSYCHOLOGY-INDIVIDUAL"
+42 SET ^TMP("SD53589P",$JOB,516)="PTSD - GROUP"
+43 SET ^TMP("SD53589P",$JOB,562)="PTSD - INDIVIDUAL"
+44 SET ^TMP("SD53589P",$JOB,540)="PTSD CLINICAL TEAM PTS IND"
+45 SET ^TMP("SD53589P",$JOB,580)="PTSD DAY HOSPITAL"
+46 SET ^TMP("SD53589P",$JOB,596)="RRTP ADMISSION SCREENING SRVCS"
+47 SET ^TMP("SD53589P",$JOB,595)="RRTP AFTERCARE GRP"
+48 SET ^TMP("SD53589P",$JOB,588)="RRTP AFTERCARE IND"
+49 SET ^TMP("SD53589P",$JOB,598)="RRTP PRE-ADMIT IND"
+50 SET ^TMP("SD53589P",$JOB,572)="SERV-MH GROUP"
+51 SET ^TMP("SD53589P",$JOB,571)="SERV-MH INDIVIDUAL"
+52 SET ^TMP("SD53589P",$JOB,707)="SMOKING CESSATION^YES"
+53 SET ^TMP("SD53589P",$JOB,514)="SUB USE DISORDER HOME VST"
+54 SET ^TMP("SD53589P",$JOB,519)="SUBST USE DISORDER/PTSD TEAMS"
+55 SET ^TMP("SD53589P",$JOB,513)="SUBSTANCE USE DISORDER IND"
+56 SET ^TMP("SD53589P",$JOB,560)="SUBSTANCE USE DISORDR GRP"
+57 SET ^TMP("SD53589P",$JOB,708)="TELE SMOKE CESS PROV SITE^YES"
+58 SET ^TMP("SD53589P",$JOB,525)="WOMEN'S STRESS DISORDER TEAMS"
+59 ;
+60 DO START
+61 SET $PIECE(^SCTM(404.61,0),"^",3)=CC
+62 SET $PIECE(^SCTM(404.61,0),"^",4)=CC
+63 DO EXIT
+64 QUIT
+65 ;
START ;
+1 ;
+2 SET (IEN,SC,CC,REC)=""
+3 SET SC=""
FOR
SET SC=$ORDER(^TMP("SD53589P",$JOB,SC))
if SC=""
QUIT
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(^DIC(40.7,"C",SC,IEN))
if IEN=""
QUIT
Begin DoDot:2
+5 if $$GET1^DIQ(40.7,IEN,2)'=""
QUIT
+6 SET CC=CC+1
SET REC=""
+7 IF $PIECE(^TMP("SD53589P",$JOB,SC),"^",2)="YES"
Begin DoDot:3
+8 SET ^SCTM(404.61,CC,0)=IEN_"^"_1
SET REC=1
+9 SET ^SCTM(404.61,"AC",1,CC)=""
End DoDot:3
+10 IF REC=""
SET ^SCTM(404.61,CC,0)=IEN
+11 SET ^SCTM(404.61,"B",IEN,CC)=""
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
EXIT ;
+1 KILL IEN,CC,SC,REC
+2 KILL ^TMP("SD53589P",$JOB)
+3 QUIT
