YTQROPT ;SLC/KCM - MHA Assignment Options ; 1/25/2017
;;5.01;MENTAL HEALTH;**130,141,217**;Dec 30, 1994;Build 12
;
; Reference to ^DPT in ICR #10035
; Reference to ^DIC in ICR #10006
; Reference to $$GET1^DIQ,EN^DIQ in ICR #2056
; Reference to $$FMTE^XLFDT in ICR #10103
;
LSTBYPT ; List assignments by patient
; Option: YTQR ASSIGNMENT BY PATIENT
N X,Y,DIC,DUOUT,DTOUT,YSDFN,OUT
S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC I Y'>0 QUIT
D BLD4PT(+Y,.OUT)
I '$D(OUT) W !,?5,"No assignments found for this patient",! QUIT
W ! D SHO4PT(.OUT) W !
Q
;
BLD4PT(YSDFN,OUT) ; List assignments for patient in OUT
; ^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,SETID)=EXPIRE
N PRV,PRVNM,SET,EXPIRE K OUT
S PRV=0 F S PRV=$O(^XTMP("YTQASMT-INDEX","AD",YSDFN,PRV)) Q:'PRV D
. S SET=0 F S SET=$O(^XTMP("YTQASMT-INDEX","AD",YSDFN,PRV,SET)) Q:'SET D
. . I $G(^XTMP("YTQASMT-SET-"_SET,1,"entryMode"))'="patient" QUIT
. . S PRVNM=$$GET1^DIQ(200,PRV_",",.01)
. . S EXPIRE=^XTMP("YTQASMT-INDEX","AD",YSDFN,PRV,SET)
. . S OUT(PRVNM,SET)=$$FMTE^XLFDT(EXPIRE)
Q
SHO4PT(OUT) ; Display assignment information
N PRVNM,SET
W !,?5,"Provider",?34,"PIN",?40,"Expires"
W !,?5,"--------",?34,"---",?40,"-------"
S PRVNM="" F S PRVNM=$O(OUT(PRVNM)) Q:'$L(PRVNM) D
. S SET=0 F S SET=$O(OUT(PRVNM,SET)) Q:'SET D
. . W !,?5,PRVNM,?32,$J(SET,6),?40,OUT(PRVNM,SET)
Q
LSTALL ; List all active assignments
N YSDFN,PTNM,OUT
S YSDFN=0 F S YSDFN=$O(^XTMP("YTQASMT-INDEX","AD",YSDFN)) Q:'YSDFN D
. D BLD4PT(YSDFN,.OUT) Q:'$D(OUT)
. S PTNM=$$GET1^DIQ(2,YSDFN_",",.01)
. W !!,?10,"---- ",PTNM," ----"
. D SHO4PT(.OUT)
Q
ADMDTL ; List details of an administration
; Option: YTQR ADMINISTRATION DETAIL
N X,Y,DIC,DIR,DUOUT,DTOUT,DIRUT,DIROUT
N YSDFN,YSDT,YSDTX,YSTST,YSAD,YSCNT,YSDETAIL
W !,"--- List Administration Details ---",!
S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC I Y'>0 QUIT
S YSDFN=+Y
S DIR(0)="D^::EP",DIR("A")="Date of Administration(s)" D ^DIR Q:$D(DIRUT)
S YSDT=$P(Y,"."),YSTST=0,YSCNT=0
S YSDETAIL=$$OKDETAIL()
W !
S YSAD=0 F S YSAD=$O(^YTT(601.84,"C",YSDFN,YSAD)) Q:'YSAD D
. I $P($P($G(^YTT(601.84,YSAD,0)),U,4),".")'=YSDT Q
. S YSCNT=YSCNT+1
. D SHOADM(YSAD)
. I YSDETAIL D SHOFULL(YSAD)
I YSCNT=0 W !,"No administrations found."
Q
OKDETAIL() ; return 1 if OK to show details
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR("A")="Show full details for each administration"
S DIR(0)="Y",DIR("B")="NO" D ^DIR
Q +Y
;
SHOADM(YSAD) ; Show all fields for administration
N DIC,DA,DR
S DIC="^YTT(601.84,",DA=YSAD
D EN^DIQ
Q
SHOFULL(YSAD) ; Show answers & results for administration
N I,J,X
; show answer index & records
W !," --- Answer Records ---"
S I=0 F S I=$O(^YTT(601.85,"AD",YSAD,I)) Q:'I D
. W !,?2,I,"=",$G(^YTT(601.85,I,0))
. I $D(^YTT(601.85,I,1)) S J=0 F S J=$O(^YTT(601.85,I,1,J)) Q:'J D
. . W !,?4,$G(^YTT(601.85,I,1,J,0))
; show result index & records
W !," --- Result Records ---"
S I=0 F S I=$O(^YTT(601.92,"AC",YSAD,I)) Q:'I D
. W !,?2,I,"=",$G(^YTT(601.92,I,0))
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQROPT 3099 printed Sep 23, 2025@19:54:58 Page 2
YTQROPT ;SLC/KCM - MHA Assignment Options ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130,141,217**;Dec 30, 1994;Build 12
+2 ;
+3 ; Reference to ^DPT in ICR #10035
+4 ; Reference to ^DIC in ICR #10006
+5 ; Reference to $$GET1^DIQ,EN^DIQ in ICR #2056
+6 ; Reference to $$FMTE^XLFDT in ICR #10103
+7 ;
LSTBYPT ; List assignments by patient
+1 ; Option: YTQR ASSIGNMENT BY PATIENT
+2 NEW X,Y,DIC,DUOUT,DTOUT,YSDFN,OUT
+3 SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
IF Y'>0
QUIT
+4 DO BLD4PT(+Y,.OUT)
+5 IF '$DATA(OUT)
WRITE !,?5,"No assignments found for this patient",!
QUIT
+6 WRITE !
DO SHO4PT(.OUT)
WRITE !
+7 QUIT
+8 ;
BLD4PT(YSDFN,OUT) ; List assignments for patient in OUT
+1 ; ^XTMP("YTQASMT-INDEX","AD",DFN,ORDBY,SETID)=EXPIRE
+2 NEW PRV,PRVNM,SET,EXPIRE
KILL OUT
+3 SET PRV=0
FOR
SET PRV=$ORDER(^XTMP("YTQASMT-INDEX","AD",YSDFN,PRV))
if 'PRV
QUIT
Begin DoDot:1
+4 SET SET=0
FOR
SET SET=$ORDER(^XTMP("YTQASMT-INDEX","AD",YSDFN,PRV,SET))
if 'SET
QUIT
Begin DoDot:2
+5 IF $GET(^XTMP("YTQASMT-SET-"_SET,1,"entryMode"))'="patient"
QUIT
+6 SET PRVNM=$$GET1^DIQ(200,PRV_",",.01)
+7 SET EXPIRE=^XTMP("YTQASMT-INDEX","AD",YSDFN,PRV,SET)
+8 SET OUT(PRVNM,SET)=$$FMTE^XLFDT(EXPIRE)
End DoDot:2
End DoDot:1
+9 QUIT
SHO4PT(OUT) ; Display assignment information
+1 NEW PRVNM,SET
+2 WRITE !,?5,"Provider",?34,"PIN",?40,"Expires"
+3 WRITE !,?5,"--------",?34,"---",?40,"-------"
+4 SET PRVNM=""
FOR
SET PRVNM=$ORDER(OUT(PRVNM))
if '$LENGTH(PRVNM)
QUIT
Begin DoDot:1
+5 SET SET=0
FOR
SET SET=$ORDER(OUT(PRVNM,SET))
if 'SET
QUIT
Begin DoDot:2
+6 WRITE !,?5,PRVNM,?32,$JUSTIFY(SET,6),?40,OUT(PRVNM,SET)
End DoDot:2
End DoDot:1
+7 QUIT
LSTALL ; List all active assignments
+1 NEW YSDFN,PTNM,OUT
+2 SET YSDFN=0
FOR
SET YSDFN=$ORDER(^XTMP("YTQASMT-INDEX","AD",YSDFN))
if 'YSDFN
QUIT
Begin DoDot:1
+3 DO BLD4PT(YSDFN,.OUT)
if '$DATA(OUT)
QUIT
+4 SET PTNM=$$GET1^DIQ(2,YSDFN_",",.01)
+5 WRITE !!,?10,"---- ",PTNM," ----"
+6 DO SHO4PT(.OUT)
End DoDot:1
+7 QUIT
ADMDTL ; List details of an administration
+1 ; Option: YTQR ADMINISTRATION DETAIL
+2 NEW X,Y,DIC,DIR,DUOUT,DTOUT,DIRUT,DIROUT
+3 NEW YSDFN,YSDT,YSDTX,YSTST,YSAD,YSCNT,YSDETAIL
+4 WRITE !,"--- List Administration Details ---",!
+5 SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
IF Y'>0
QUIT
+6 SET YSDFN=+Y
+7 SET DIR(0)="D^::EP"
SET DIR("A")="Date of Administration(s)"
DO ^DIR
if $DATA(DIRUT)
QUIT
+8 SET YSDT=$PIECE(Y,".")
SET YSTST=0
SET YSCNT=0
+9 SET YSDETAIL=$$OKDETAIL()
+10 WRITE !
+11 SET YSAD=0
FOR
SET YSAD=$ORDER(^YTT(601.84,"C",YSDFN,YSAD))
if 'YSAD
QUIT
Begin DoDot:1
+12 IF $PIECE($PIECE($GET(^YTT(601.84,YSAD,0)),U,4),".")'=YSDT
QUIT
+13 SET YSCNT=YSCNT+1
+14 DO SHOADM(YSAD)
+15 IF YSDETAIL
DO SHOFULL(YSAD)
End DoDot:1
+16 IF YSCNT=0
WRITE !,"No administrations found."
+17 QUIT
OKDETAIL() ; return 1 if OK to show details
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR("A")="Show full details for each administration"
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+4 QUIT +Y
+5 ;
SHOADM(YSAD) ; Show all fields for administration
+1 NEW DIC,DA,DR
+2 SET DIC="^YTT(601.84,"
SET DA=YSAD
+3 DO EN^DIQ
+4 QUIT
SHOFULL(YSAD) ; Show answers & results for administration
+1 NEW I,J,X
+2 ; show answer index & records
+3 WRITE !," --- Answer Records ---"
+4 SET I=0
FOR
SET I=$ORDER(^YTT(601.85,"AD",YSAD,I))
if 'I
QUIT
Begin DoDot:1
+5 WRITE !,?2,I,"=",$GET(^YTT(601.85,I,0))
+6 IF $DATA(^YTT(601.85,I,1))
SET J=0
FOR
SET J=$ORDER(^YTT(601.85,I,1,J))
if 'J
QUIT
Begin DoDot:2
+7 WRITE !,?4,$GET(^YTT(601.85,I,1,J,0))
End DoDot:2
End DoDot:1
+8 ; show result index & records
+9 WRITE !," --- Result Records ---"
+10 SET I=0
FOR
SET I=$ORDER(^YTT(601.92,"AC",YSAD,I))
if 'I
QUIT
Begin DoDot:1
+11 WRITE !,?2,I,"=",$GET(^YTT(601.92,I,0))
End DoDot:1
+12 WRITE !
+13 QUIT
