PXRMLPOE ;SLC/PJH,PKR - Build OE/RR Team from Patient List ;02/21/2014
;;2.0;CLINICAL REMINDERS;**4,24,26**;Feb 04, 2005;Build 404
;
; Called from PXRM PATIENT LIST OE/RR protocol
ASK(PLIEN,OPT) ;Verify patient list name
N DIR,X,Y,TEXT
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA0"
S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
S DIR("B")="N"
S DIR("?")="Enter Y or N. For detailed help type ??"
W !
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
I $E(Y(0))="N" S DUOUT=1 Q
Q
;
LOCK(LIST) ;Lock the list
L +^PXRMXP(100.21,LIST):DILOCKTM
E W !!?5,"Another user is using this OE/RR team list" S DUOUT=1
Q
;
OERR(IENO) ;Copy patient list to OE/RR Team
;Check if OK to copy
D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
;
N IENN,NNAME,ONAME,TEXT,X,Y
;
;Select OE/RR Team to copy to
S TEXT="Select OE/RR TEAM name to copy to: "
D OTEAM(.IENN,.NNAME,TEXT) Q:$D(DUOUT)!$D(DTOUT) Q:'IENN
;
S ONAME=$P($G(^PXRMXP(810.5,IENO,0)),U)
;
;Update OE/RR Team list
D UPDLST(IENO,IENN,NNAME)
Q
;
OK ;Option to overwrite existing list
N X,Y,TEXT
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="YA0"
S DIR("A")="Overwrite existing OE/RR Team list: "
S DIR("B")="N"
S DIR("?")="Enter Y or N. For detailed help type ??"
S DIR("??")=U_"D HELP^PXRMLCR(1)"
W !
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) Q
I $E(Y(0))="N" S DUOUT=1 Q
Q
;
OTEAM(LIST,NAME,TEXT) ;Select OERR/Team
N X,Y,DIC,DIE,DR,DLAYGO
W !
W !,"To overwrite an existing list you must be the creator of the list and"
W !,"the OE/RR team list must be defined as a Team List."
OT1 S DIC=100.21,DLAYGO=DIC,DIC(0)="QAEMZL"
S DIC("S")="I $P($G(^(0)),U,2)=""TM"",$P($G(^(0)),U,5)=DUZ"
S DIC("A")=TEXT
W !
D ^DIC
I X="" W !,"An OE/RR Team name must be entered" G OT1
I X=(U_U) S DTOUT=1
I Y=-1 S DUOUT=1
I $D(DTOUT)!$D(DUOUT) Q
;
;Check if OK to overwrite
I $P(Y,U,3)'=1 D Q:$D(DTOUT) G:$D(DUOUT) OT1
.D OK
;Return list ien
S LIST=$P(Y,U),NAME=$P(Y,U,2)
Q
;
UPDLST(IENO,LIST,NAME) ;Update patient list
N CNT,DA,DFN,DIK,DUOUT,FDA,FDAIEN,IEN,MSG,SUB,TEMP
;Lock patient list
D LOCK(LIST) Q:$D(DUOUT)
;
;Clear existing list
S SUB=0
F S SUB=$O(^OR(100.21,LIST,10,SUB)) Q:'SUB D
. S DA=SUB,DA(1)=LIST,DIK="^OR(100.21,"_DA(1)_",10,"
. D ^DIK
;
;DBIA #4561 covers putting data into OE/RR list.
;Create the stub in file #100.21
W !,"Updating "_NAME
S FDA(100.21,"?1,",.01)=NAME
S FDA(100.21,"?1,",.1)=$$UP^XLFSTR(NAME)
S FDA(100.21,"?1,",1)="TM"
S FDA(100.21,"?1,",1.6)=DUZ
S FDA(100.21,"?1,",1.65)=$$NOW^XLFDT
S FDA(100.21,"?1,",11)="0"
D UPDATE^DIE("","FDA","FDAIEN","MSG")
;Error
I $D(MSG) D Q
. N TEXT
. S TEXT(1)="The patient list copy failed."
. S TEXT(2)="Examine the following error message for the reason."
. S TEXT(3)=""
. D MES^XPDUTL(.TEXT)
. D AWRITE^PXRMUTIL("MSG")
. W ! H 3
. D UNLOCK(LIST)
;Do a direct copy of the patients.
S (CNT,SUB)=0,IEN=FDAIEN(1)
F S SUB=$O(^PXRMXP(810.5,IENO,30,SUB)) Q:'SUB D
. S DFN=$P($G(^PXRMXP(810.5,IENO,30,SUB,0)),U,1) Q:'DFN
. S CNT=CNT+1
. S TEMP=DFN_";DPT("
. S ^OR(100.21,IEN,10,CNT,0)=TEMP
. S ^OR(100.21,IEN,10,"B",TEMP,CNT)=""
. S ^OR(100.21,"AB",TEMP,IEN,CNT)=""
S ^OR(100.21,IEN,10,0)="^100.2101AV"_U_CNT_U_CNT
;Unlock patient list
D UNLOCK(LIST)
W !!,"Completed copy of patient list '"_ONAME_"'"
W !,"into OE/RR Team '"_NNAME_"'",! H 3
Q
;
UNLOCK(LIST) ;Unlock the list
L -^PXRMXP(100.21,LIST)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLPOE 3573 printed Sep 23, 2025@19:22:33 Page 2
PXRMLPOE ;SLC/PJH,PKR - Build OE/RR Team from Patient List ;02/21/2014
+1 ;;2.0;CLINICAL REMINDERS;**4,24,26**;Feb 04, 2005;Build 404
+2 ;
+3 ; Called from PXRM PATIENT LIST OE/RR protocol
ASK(PLIEN,OPT) ;Verify patient list name
+1 NEW DIR,X,Y,TEXT
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="YA0"
+4 SET DIR("A")=OPT_" patient list "_$PIECE($GET(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
+5 SET DIR("B")="N"
+6 SET DIR("?")="Enter Y or N. For detailed help type ??"
+7 WRITE !
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIROUT)
SET DTOUT=1
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+11 IF $EXTRACT(Y(0))="N"
SET DUOUT=1
QUIT
+12 QUIT
+13 ;
LOCK(LIST) ;Lock the list
+1 LOCK +^PXRMXP(100.21,LIST):DILOCKTM
+2 IF '$TEST
WRITE !!?5,"Another user is using this OE/RR team list"
SET DUOUT=1
+3 QUIT
+4 ;
OERR(IENO) ;Copy patient list to OE/RR Team
+1 ;Check if OK to copy
+2 DO ASK(IENO,"Copy")
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+3 ;
+4 NEW IENN,NNAME,ONAME,TEXT,X,Y
+5 ;
+6 ;Select OE/RR Team to copy to
+7 SET TEXT="Select OE/RR TEAM name to copy to: "
+8 DO OTEAM(.IENN,.NNAME,TEXT)
if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
if 'IENN
QUIT
+9 ;
+10 SET ONAME=$PIECE($GET(^PXRMXP(810.5,IENO,0)),U)
+11 ;
+12 ;Update OE/RR Team list
+13 DO UPDLST(IENO,IENN,NNAME)
+14 QUIT
+15 ;
OK ;Option to overwrite existing list
+1 NEW X,Y,TEXT
+2 KILL DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="YA0"
+4 SET DIR("A")="Overwrite existing OE/RR Team list: "
+5 SET DIR("B")="N"
+6 SET DIR("?")="Enter Y or N. For detailed help type ??"
+7 SET DIR("??")=U_"D HELP^PXRMLCR(1)"
+8 WRITE !
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIROUT)
SET DTOUT=1
+11 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+12 IF $EXTRACT(Y(0))="N"
SET DUOUT=1
QUIT
+13 QUIT
+14 ;
OTEAM(LIST,NAME,TEXT) ;Select OERR/Team
+1 NEW X,Y,DIC,DIE,DR,DLAYGO
+2 WRITE !
+3 WRITE !,"To overwrite an existing list you must be the creator of the list and"
+4 WRITE !,"the OE/RR team list must be defined as a Team List."
OT1 SET DIC=100.21
SET DLAYGO=DIC
SET DIC(0)="QAEMZL"
+1 SET DIC("S")="I $P($G(^(0)),U,2)=""TM"",$P($G(^(0)),U,5)=DUZ"
+2 SET DIC("A")=TEXT
+3 WRITE !
+4 DO ^DIC
+5 IF X=""
WRITE !,"An OE/RR Team name must be entered"
GOTO OT1
+6 IF X=(U_U)
SET DTOUT=1
+7 IF Y=-1
SET DUOUT=1
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+9 ;
+10 ;Check if OK to overwrite
+11 IF $PIECE(Y,U,3)'=1
Begin DoDot:1
+12 DO OK
End DoDot:1
if $DATA(DTOUT)
QUIT
if $DATA(DUOUT)
GOTO OT1
+13 ;Return list ien
+14 SET LIST=$PIECE(Y,U)
SET NAME=$PIECE(Y,U,2)
+15 QUIT
+16 ;
UPDLST(IENO,LIST,NAME) ;Update patient list
+1 NEW CNT,DA,DFN,DIK,DUOUT,FDA,FDAIEN,IEN,MSG,SUB,TEMP
+2 ;Lock patient list
+3 DO LOCK(LIST)
if $DATA(DUOUT)
QUIT
+4 ;
+5 ;Clear existing list
+6 SET SUB=0
+7 FOR
SET SUB=$ORDER(^OR(100.21,LIST,10,SUB))
if 'SUB
QUIT
Begin DoDot:1
+8 SET DA=SUB
SET DA(1)=LIST
SET DIK="^OR(100.21,"_DA(1)_",10,"
+9 DO ^DIK
End DoDot:1
+10 ;
+11 ;DBIA #4561 covers putting data into OE/RR list.
+12 ;Create the stub in file #100.21
+13 WRITE !,"Updating "_NAME
+14 SET FDA(100.21,"?1,",.01)=NAME
+15 SET FDA(100.21,"?1,",.1)=$$UP^XLFSTR(NAME)
+16 SET FDA(100.21,"?1,",1)="TM"
+17 SET FDA(100.21,"?1,",1.6)=DUZ
+18 SET FDA(100.21,"?1,",1.65)=$$NOW^XLFDT
+19 SET FDA(100.21,"?1,",11)="0"
+20 DO UPDATE^DIE("","FDA","FDAIEN","MSG")
+21 ;Error
+22 IF $DATA(MSG)
Begin DoDot:1
+23 NEW TEXT
+24 SET TEXT(1)="The patient list copy failed."
+25 SET TEXT(2)="Examine the following error message for the reason."
+26 SET TEXT(3)=""
+27 DO MES^XPDUTL(.TEXT)
+28 DO AWRITE^PXRMUTIL("MSG")
+29 WRITE !
HANG 3
+30 DO UNLOCK(LIST)
End DoDot:1
QUIT
+31 ;Do a direct copy of the patients.
+32 SET (CNT,SUB)=0
SET IEN=FDAIEN(1)
+33 FOR
SET SUB=$ORDER(^PXRMXP(810.5,IENO,30,SUB))
if 'SUB
QUIT
Begin DoDot:1
+34 SET DFN=$PIECE($GET(^PXRMXP(810.5,IENO,30,SUB,0)),U,1)
if 'DFN
QUIT
+35 SET CNT=CNT+1
+36 SET TEMP=DFN_";DPT("
+37 SET ^OR(100.21,IEN,10,CNT,0)=TEMP
+38 SET ^OR(100.21,IEN,10,"B",TEMP,CNT)=""
+39 SET ^OR(100.21,"AB",TEMP,IEN,CNT)=""
End DoDot:1
+40 SET ^OR(100.21,IEN,10,0)="^100.2101AV"_U_CNT_U_CNT
+41 ;Unlock patient list
+42 DO UNLOCK(LIST)
+43 WRITE !!,"Completed copy of patient list '"_ONAME_"'"
+44 WRITE !,"into OE/RR Team '"_NNAME_"'",!
HANG 3
+45 QUIT
+46 ;
UNLOCK(LIST) ;Unlock the list
+1 LOCK -^PXRMXP(100.21,LIST)
+2 QUIT
+3 ;
