YSCEN5 ;ALB/ASF,HIOFO/FT - CENSUS HX ;8/15/12 9:38am
;;5.01;MENTAL HEALTH;**60**;Dec 30, 1994;Build 47
;
;No external references
;
CROSS ; set logic for AST x-ref in File 618.4
S:'$D(^YSG("INP",DA,6,0)) ^YSG("INP",DA,6,0)="^618.419P^0^0"
L +^YSG("INP",DA,6):DILOCKTM Q:'$T
S N=$P(^YSG("INP",DA,6,0),U,3)+1
I (N>1),$D(^YSG("INP",DA,6,N-1)),(X=+^YSG("INP",DA,6,N-1,0)) S X2=^YSG("INP",DA,6,N-1,0),W1=+^YSG("INP",DA,7),^YSG("INP","AST",9999999-$P(X2,U,2),W1,X,DA)="" L -^YSG("INP",DA,6,0) Q
S ^YSG("INP",DA,6,0)=$P(^YSG("INP",DA,6,0),U,1,2)_U_N_U_($P(^YSG("INP",DA,6,0),U,4)+1) L -^YSG("INP",DA,6)
S W1=+^YSG("INP",DA,7),YSU=X,X="NOW",%DT="T" D ^%DT S X=YSU,YSNOW=9999999-Y,^YSG("INP","AST",YSNOW,W1,X,DA)="" K YSU,YSNOW
S ^YSG("INP",DA,6,N,0)=X_U_Y_U_DUZ,^YSG("INP",DA,6,"B",X,N)=""
Q:'$D(^YSG("SUB",X,1))
Q:'$P(^YSG("SUB",X,1),U,4) S YSTM8="" F ZZ=1:1 Q:'$D(^YSG("CEN",W1,"ROT")) S YSTM7=$P(^YSG("CEN",W1,"ROT"),U,ZZ) Q:YSTM7'?1N.N S:YSTM7'=X YSTM8=YSTM8_YSTM7_U
S ^YSG("CEN",W1,"ROT")=YSTM8_X
Q
ENTRY ; set logic for AWC x-ref in File 618.4
S YSW1=+^YSG("INP",DA,7),G=^YSG("INP",DA,0)
I $P(G,U,2) S ^YSG("INP","CP",$P(G,U,2),DA)=""
I $P(G,U,5) S ^YSG("INP","AC",$P(G,U,5),DA)=""
I $P(G,U,6) S ^YSG("INP","ACP",$P(G,U,6),DA)=""
I $P(G,U,7) S ^YSG("INP","ACR",$P(G,U,7),DA)=""
S ^YSG("INP","AWC",YSW1,X,DA)="" Q
LEAVE ; kill logic for AWC x-ref in File 618.4
S YSW1=+^YSG("INP",DA,7),G=^YSG("INP",DA,0)
I $P(G,U,2) K ^YSG("INP","CP",$P(G,U,2),DA)
I $P(G,U,5) K ^YSG("INP","AC",$P(G,U,5),DA)
I $P(G,U,6) K ^YSG("INP","ACP",$P(G,U,6),DA)
I $P(G,U,7) K ^YSG("INP","ACR",$P(G,U,7),DA)
K ^YSG("INP","AWC",YSW1,X,DA) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSCEN5 1672 printed Dec 13, 2024@02:13:32 Page 2
YSCEN5 ;ALB/ASF,HIOFO/FT - CENSUS HX ;8/15/12 9:38am
+1 ;;5.01;MENTAL HEALTH;**60**;Dec 30, 1994;Build 47
+2 ;
+3 ;No external references
+4 ;
CROSS ; set logic for AST x-ref in File 618.4
+1 if '$DATA(^YSG("INP",DA,6,0))
SET ^YSG("INP",DA,6,0)="^618.419P^0^0"
+2 LOCK +^YSG("INP",DA,6):DILOCKTM
if '$TEST
QUIT
+3 SET N=$PIECE(^YSG("INP",DA,6,0),U,3)+1
+4 IF (N>1)
IF $DATA(^YSG("INP",DA,6,N-1))
IF (X=+^YSG("INP",DA,6,N-1,0))
SET X2=^YSG("INP",DA,6,N-1,0)
SET W1=+^YSG("INP",DA,7)
SET ^YSG("INP","AST",9999999-$PIECE(X2,U,2),W1,X,DA)=""
LOCK -^YSG("INP",DA,6,0)
QUIT
+5 SET ^YSG("INP",DA,6,0)=$PIECE(^YSG("INP",DA,6,0),U,1,2)_U_N_U_($PIECE(^YSG("INP",DA,6,0),U,4)+1)
LOCK -^YSG("INP",DA,6)
+6 SET W1=+^YSG("INP",DA,7)
SET YSU=X
SET X="NOW"
SET %DT="T"
DO ^%DT
SET X=YSU
SET YSNOW=9999999-Y
SET ^YSG("INP","AST",YSNOW,W1,X,DA)=""
KILL YSU,YSNOW
+7 SET ^YSG("INP",DA,6,N,0)=X_U_Y_U_DUZ
SET ^YSG("INP",DA,6,"B",X,N)=""
+8 if '$DATA(^YSG("SUB",X,1))
QUIT
+9 if '$PIECE(^YSG("SUB",X,1),U,4)
QUIT
SET YSTM8=""
FOR ZZ=1:1
if '$DATA(^YSG("CEN",W1,"ROT"))
QUIT
SET YSTM7=$PIECE(^YSG("CEN",W1,"ROT"),U,ZZ)
if YSTM7'?1N.N
QUIT
if YSTM7'=X
SET YSTM8=YSTM8_YSTM7_U
+10 SET ^YSG("CEN",W1,"ROT")=YSTM8_X
+11 QUIT
ENTRY ; set logic for AWC x-ref in File 618.4
+1 SET YSW1=+^YSG("INP",DA,7)
SET G=^YSG("INP",DA,0)
+2 IF $PIECE(G,U,2)
SET ^YSG("INP","CP",$PIECE(G,U,2),DA)=""
+3 IF $PIECE(G,U,5)
SET ^YSG("INP","AC",$PIECE(G,U,5),DA)=""
+4 IF $PIECE(G,U,6)
SET ^YSG("INP","ACP",$PIECE(G,U,6),DA)=""
+5 IF $PIECE(G,U,7)
SET ^YSG("INP","ACR",$PIECE(G,U,7),DA)=""
+6 SET ^YSG("INP","AWC",YSW1,X,DA)=""
QUIT
LEAVE ; kill logic for AWC x-ref in File 618.4
+1 SET YSW1=+^YSG("INP",DA,7)
SET G=^YSG("INP",DA,0)
+2 IF $PIECE(G,U,2)
KILL ^YSG("INP","CP",$PIECE(G,U,2),DA)
+3 IF $PIECE(G,U,5)
KILL ^YSG("INP","AC",$PIECE(G,U,5),DA)
+4 IF $PIECE(G,U,6)
KILL ^YSG("INP","ACP",$PIECE(G,U,6),DA)
+5 IF $PIECE(G,U,7)
KILL ^YSG("INP","ACR",$PIECE(G,U,7),DA)
+6 KILL ^YSG("INP","AWC",YSW1,X,DA)
QUIT
