QAMC15 ;HISC/DAD-CONDITION: WARD TRANSFER ;7/27/92 13:04
;;1.0;Clinical Monitoring System;;09/13/1993
EN1 ; *** CONDITION CODE
S WARDGRP=$S($D(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:+^("P1"),1:0)
F WARDDT=(QAMTODAY-.0000001):0 S WARDDT=$O(^DGPM("AMV2",WARDDT)) Q:(WARDDT'>0)!(WARDDT\1'?7N)!(WARDDT>(QAMTODAY+.9999999)) F QAMDFN=0:0 S QAMDFN=$O(^DGPM("AMV2",WARDDT,QAMDFN)) Q:QAMDFN'>0 D LOOP0
K WARDGRP,WARDDT,WARDD0,WARD,QAMDGPM
Q
LOOP0 F WARDD0=0:0 S WARDD0=$O(^DGPM("AMV2",WARDDT,QAMDFN,WARDD0)) Q:WARDD0'>0 D LOOP1
Q
LOOP1 S QAMDGPM=$G(^DGPM(WARDD0,0)) Q:$P(QAMDGPM,"^",18)'=4 ; INTERWARD XFR
I WARDGRP S WARD=+$P(QAMDGPM,"^",6) Q:$O(^QA(743.5,WARDGRP,"GRP","AB",WARD,0))'>0
S ^UTILITY($J,"QAM CONDITION",QAMD1,QAMDFN)="",^(QAMDFN,WARDDT)=WARDD0
Q
EN2 ; *** PARAMETER CODE
K DIC,DIR,DIRUT S DIC=743.5,DIC(0)="EMNQZ",DIC("S")="I $P(^QA(743.5,+Y,0),""^"",2)=42"
S DIC("A")="WARD GROUP: ",DIC("B")=$S($D(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:$P(^("P1"),"^",2),1:"") K:DIC("B")="" DIC("B")
S DIR("?",1)="Enter a GROUP name that contains MAS ward locations,",DIR("?")="or press 'RETURN' for all ward locations."
S QAMPARAM="P1" D EN2^QAMUTL1 I $D(DIRUT) S Y=-1 G Y
S:Y]"" ^QA(743,QAMD0,"COND",QAMD1,"P1")=+Y_"^"_Y(0,0)
EXIT K Y
K QAMPARAM,QAMY
Y Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAMC15 1285 printed Dec 13, 2024@01:41:59 Page 2
QAMC15 ;HISC/DAD-CONDITION: WARD TRANSFER ;7/27/92 13:04
+1 ;;1.0;Clinical Monitoring System;;09/13/1993
EN1 ; *** CONDITION CODE
+1 SET WARDGRP=$SELECT($DATA(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:+^("P1"),1:0)
+2 FOR WARDDT=(QAMTODAY-.0000001):0
SET WARDDT=$ORDER(^DGPM("AMV2",WARDDT))
if (WARDDT'>0)!(WARDDT\1'?7N)!(WARDDT>(QAMTODAY+.9999999))
QUIT
FOR QAMDFN=0:0
SET QAMDFN=$ORDER(^DGPM("AMV2",WARDDT,QAMDFN))
if QAMDFN'>0
QUIT
DO LOOP0
+3 KILL WARDGRP,WARDDT,WARDD0,WARD,QAMDGPM
+4 QUIT
LOOP0 FOR WARDD0=0:0
SET WARDD0=$ORDER(^DGPM("AMV2",WARDDT,QAMDFN,WARDD0))
if WARDD0'>0
QUIT
DO LOOP1
+1 QUIT
LOOP1 ; INTERWARD XFR
SET QAMDGPM=$GET(^DGPM(WARDD0,0))
if $PIECE(QAMDGPM,"^",18)'=4
QUIT
+1 IF WARDGRP
SET WARD=+$PIECE(QAMDGPM,"^",6)
if $ORDER(^QA(743.5,WARDGRP,"GRP","AB",WARD,0))'>0
QUIT
+2 SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAMDFN)=""
SET ^(QAMDFN,WARDDT)=WARDD0
+3 QUIT
EN2 ; *** PARAMETER CODE
+1 KILL DIC,DIR,DIRUT
SET DIC=743.5
SET DIC(0)="EMNQZ"
SET DIC("S")="I $P(^QA(743.5,+Y,0),""^"",2)=42"
+2 SET DIC("A")="WARD GROUP: "
SET DIC("B")=$SELECT($DATA(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:$PIECE(^("P1"),"^",2),1:"")
if DIC("B")=""
KILL DIC("B")
+3 SET DIR("?",1)="Enter a GROUP name that contains MAS ward locations,"
SET DIR("?")="or press 'RETURN' for all ward locations."
+4 SET QAMPARAM="P1"
DO EN2^QAMUTL1
IF $DATA(DIRUT)
SET Y=-1
GOTO Y
+5 if Y]""
SET ^QA(743,QAMD0,"COND",QAMD1,"P1")=+Y_"^"_Y(0,0)
EXIT KILL Y
+1 KILL QAMPARAM,QAMY
Y QUIT
